cabal-install 0.8.2 → 0.10.0
raw patch · 34 files changed
+2821/−1372 lines, 34 filesdep ~Cabaldep ~containersdep ~directory
Dependency ranges changed: Cabal, containers, directory, filepath, network, time
Files
- Distribution/Client/BuildReports/Storage.hs +2/−4
- Distribution/Client/BuildReports/Upload.hs +11/−8
- Distribution/Client/Config.hs +39/−72
- Distribution/Client/Configure.hs +34/−52
- Distribution/Client/Dependency.hs +328/−120
- Distribution/Client/Dependency/Bogus.hs +0/−129
- Distribution/Client/Dependency/TopDown.hs +1/−1
- Distribution/Client/Dependency/TopDown/Constraints.hs +1/−1
- Distribution/Client/Dependency/Types.hs +1/−0
- Distribution/Client/Fetch.hs +122/−143
- Distribution/Client/FetchUtils.hs +193/−0
- Distribution/Client/GZipUtils.hs +44/−0
- Distribution/Client/Haddock.hs +8/−4
- Distribution/Client/IndexUtils.hs +27/−62
- Distribution/Client/Init/Heuristics.hs +6/−2
- Distribution/Client/Install.hs +407/−318
- Distribution/Client/InstallPlan.hs +17/−1
- Distribution/Client/List.hs +251/−91
- Distribution/Client/PackageIndex.hs +15/−16
- Distribution/Client/Setup.hs +154/−21
- Distribution/Client/SetupWrapper.hs +5/−6
- Distribution/Client/Tar.hs +54/−21
- Distribution/Client/Targets.hs +650/−0
- Distribution/Client/Types.hs +34/−19
- Distribution/Client/Unpack.hs +63/−58
- Distribution/Client/Update.hs +3/−3
- Distribution/Client/Upload.hs +33/−20
- Distribution/Client/World.hs +173/−0
- Distribution/Compat/FilePerms.hs +40/−0
- Main.hs +57/−41
- README +1/−1
- bash-completion/cabal +0/−107
- bootstrap.sh +32/−39
- cabal-install.cabal +15/−12
Distribution/Client/BuildReports/Storage.hs view
@@ -26,8 +26,6 @@ import Distribution.Client.BuildReports.Anonymous (BuildReport) import Distribution.Client.Types- ( ConfiguredPackage(..), AvailablePackage(..)- , AvailablePackageSource(..), Repo(..), RemoteRepo(..) ) import qualified Distribution.Client.InstallPlan as InstallPlan import Distribution.Client.InstallPlan ( InstallPlan )@@ -119,11 +117,11 @@ fromPlanPackage (Platform arch os) comp planPackage = case planPackage of InstallPlan.Installed pkg@(ConfiguredPackage (AvailablePackage {- packageSource = RepoTarballPackage repo }) _ _) result+ packageSource = RepoTarballPackage repo _ _ }) _ _) result -> Just $ (BuildReport.new os arch comp pkg (Right result), repo) InstallPlan.Failed pkg@(ConfiguredPackage (AvailablePackage {- packageSource = RepoTarballPackage repo }) _ _) result+ packageSource = RepoTarballPackage repo _ _ }) _ _) result -> Just $ (BuildReport.new os arch comp pkg (Left result), repo) _ -> Nothing
Distribution/Client/BuildReports/Upload.hs view
@@ -23,25 +23,28 @@ ( (</>) ) import qualified Distribution.Client.BuildReports.Anonymous as BuildReport import Distribution.Client.BuildReports.Anonymous (BuildReport)+import Distribution.Text (display) type BuildReportId = URI type BuildLog = String uploadReports :: URI -> [(BuildReport, Maybe BuildLog)]+ -> BrowserAction (HandleStream String) () -> BrowserAction (HandleStream BuildLog) ()-uploadReports uri reports- = forM_ reports $ \(report, mbBuildLog) ->- do buildId <- postBuildReport uri report- case mbBuildLog of- Just buildLog -> putBuildLog buildId buildLog- Nothing -> return ()+uploadReports uri reports auth = do+ auth+ forM_ reports $ \(report, mbBuildLog) -> do+ buildId <- postBuildReport uri report+ case mbBuildLog of+ Just buildLog -> putBuildLog buildId buildLog+ Nothing -> return () postBuildReport :: URI -> BuildReport -> BrowserAction (HandleStream BuildLog) BuildReportId postBuildReport uri buildReport = do setAllowRedirects False (_, response) <- request Request {- rqURI = uri { uriPath = "/buildreports" },+ rqURI = uri { uriPath = "/package" </> display (BuildReport.package buildReport) </> "reports" }, rqMethod = POST, rqHeaders = [Header HdrContentType ("text/plain"), Header HdrContentLength (show (length body)),@@ -61,7 +64,7 @@ putBuildLog reportId buildLog = do --FIXME: do something if the request fails (_, response) <- request Request {- rqURI = reportId{uriPath = uriPath reportId </> "buildlog"},+ rqURI = reportId{uriPath = uriPath reportId </> "log"}, rqMethod = PUT, rqHeaders = [Header HdrContentType ("text/plain"), Header HdrContentLength (show (length buildLog)),
Distribution/Client/Config.hs view
@@ -34,28 +34,28 @@ , ConfigExFlags(..), configureExOptions, defaultConfigExFlags , InstallFlags(..), installOptions, defaultInstallFlags , UploadFlags(..), uploadCommand+ , ReportFlags(..), reportCommand , showRepo, parseRepo ) import Distribution.Simple.Setup ( ConfigFlags(..), configureOptions, defaultConfigFlags- , Flag, toFlag, flagToMaybe, fromFlagOrDefault, flagToList )+ , installDirsOptions+ , Flag, toFlag, flagToMaybe, fromFlagOrDefault ) import Distribution.Simple.InstallDirs ( InstallDirs(..), defaultInstallDirs- , PathTemplate, toPathTemplate, fromPathTemplate )+ , PathTemplate, toPathTemplate ) import Distribution.ParseUtils ( FieldDescr(..), liftField , ParseResult(..), locatedErrorMsg, showPWarning , readFields, warning, lineNo- , simpleField, listField, parseFilePathQ, showFilePath, parseTokenQ )+ , simpleField, listField, parseFilePathQ, parseTokenQ ) import qualified Distribution.ParseUtils as ParseUtils ( Field(..) ) import qualified Distribution.Text as Text ( Text(..) )-import Distribution.ReadE- ( readP_to_E ) import Distribution.Simple.Command ( CommandUI(commandOptions), commandDefaultFlags, ShowOrParseArgs(..)- , viewAsFieldDescr, OptionField, option, reqArg )+ , viewAsFieldDescr ) import Distribution.Simple.Program ( defaultProgramConfiguration ) import Distribution.Simple.Utils@@ -102,7 +102,8 @@ savedConfigureExFlags :: ConfigExFlags, savedUserInstallDirs :: InstallDirs (Flag PathTemplate), savedGlobalInstallDirs :: InstallDirs (Flag PathTemplate),- savedUploadFlags :: UploadFlags+ savedUploadFlags :: UploadFlags,+ savedReportFlags :: ReportFlags } instance Monoid SavedConfig where@@ -113,7 +114,8 @@ savedConfigureExFlags = mempty, savedUserInstallDirs = mempty, savedGlobalInstallDirs = mempty,- savedUploadFlags = mempty+ savedUploadFlags = mempty,+ savedReportFlags = mempty } mappend a b = SavedConfig { savedGlobalFlags = combine savedGlobalFlags,@@ -122,7 +124,8 @@ savedConfigureExFlags = combine savedConfigureExFlags, savedUserInstallDirs = combine savedUserInstallDirs, savedGlobalInstallDirs = combine savedGlobalInstallDirs,- savedUploadFlags = combine savedUploadFlags+ savedUploadFlags = combine savedUploadFlags,+ savedReportFlags = combine savedReportFlags } where combine field = field a `mappend` field b @@ -156,6 +159,8 @@ baseSavedConfig :: IO SavedConfig baseSavedConfig = do userPrefix <- defaultCabalDir+ logsDir <- defaultLogsDir+ worldFile <- defaultWorldFile return mempty { savedConfigureFlags = mempty { configHcFlavor = toFlag defaultCompiler,@@ -164,6 +169,10 @@ }, savedUserInstallDirs = mempty { prefix = toFlag (toPathTemplate userPrefix)+ },+ savedGlobalFlags = mempty {+ globalLogsDir = toFlag logsDir,+ globalWorldFile = toFlag worldFile } } @@ -177,10 +186,12 @@ initialSavedConfig = do cacheDir <- defaultCacheDir logsDir <- defaultLogsDir+ worldFile <- defaultWorldFile return mempty { savedGlobalFlags = mempty { globalCacheDir = toFlag cacheDir,- globalRemoteRepos = [defaultRemoteRepo]+ globalRemoteRepos = [defaultRemoteRepo],+ globalWorldFile = toFlag worldFile }, savedInstallFlags = mempty { installSummaryFile = [toPathTemplate (logsDir </> "build.log")],@@ -188,6 +199,8 @@ } } +--TODO: misleading, there's no way to override this default+-- either make it possible or rename to simply getCabalDir. defaultCabalDir :: IO FilePath defaultCabalDir = getAppUserDataDirectory "cabal" @@ -206,6 +219,12 @@ dir <- defaultCabalDir return $ dir </> "logs" +-- | Default position of the world file+defaultWorldFile :: IO FilePath+defaultWorldFile = do+ dir <- defaultCabalDir+ return $ dir </> "world"+ defaultCompiler :: CompilerFlavor defaultCompiler = fromMaybe GHC defaultCompilerFlavor @@ -309,7 +328,8 @@ }, savedUserInstallDirs = fmap toFlag userInstallDirs, savedGlobalInstallDirs = fmap toFlag globalInstallDirs,- savedUploadFlags = commandDefaultFlags uploadCommand+ savedUploadFlags = commandDefaultFlags uploadCommand,+ savedReportFlags = commandDefaultFlags reportCommand } -- | All config file fields.@@ -345,6 +365,10 @@ (commandOptions uploadCommand ParseArgs) ["verbose", "check"] [] + ++ toSavedConfig liftReportFlag+ (commandOptions reportCommand ParseArgs)+ ["verbose"] []+ where toSavedConfig lift options exclusions replacements = [ lift (fromMaybe field replacement)@@ -415,6 +439,10 @@ liftUploadFlag = liftField savedUploadFlags (\flags conf -> conf { savedUploadFlags = flags }) +liftReportFlag :: FieldDescr ReportFlags -> FieldDescr SavedConfig+liftReportFlag = liftField+ savedReportFlags (\flags conf -> conf { savedReportFlags = flags })+ parseConfig :: SavedConfig -> String -> ParseResult SavedConfig parseConfig initial = \str -> do fields <- readFields str@@ -502,64 +530,3 @@ installDirsFields :: [FieldDescr (InstallDirs (Flag PathTemplate))] installDirsFields = map viewAsFieldDescr installDirsOptions ---TODO: this is now exported in Cabal-1.5-installDirsOptions :: [OptionField (InstallDirs (Flag PathTemplate))]-installDirsOptions =- [ option "" ["prefix"]- "bake this prefix in preparation of installation"- prefix (\v flags -> flags { prefix = v })- installDirArg-- , option "" ["bindir"]- "installation directory for executables"- bindir (\v flags -> flags { bindir = v })- installDirArg-- , option "" ["libdir"]- "installation directory for libraries"- libdir (\v flags -> flags { libdir = v })- installDirArg-- , option "" ["libsubdir"]- "subdirectory of libdir in which libs are installed"- libsubdir (\v flags -> flags { libsubdir = v })- installDirArg-- , option "" ["libexecdir"]- "installation directory for program executables"- libexecdir (\v flags -> flags { libexecdir = v })- installDirArg-- , option "" ["datadir"]- "installation directory for read-only data"- datadir (\v flags -> flags { datadir = v })- installDirArg-- , option "" ["datasubdir"]- "subdirectory of datadir in which data files are installed"- datasubdir (\v flags -> flags { datasubdir = v })- installDirArg-- , option "" ["docdir"]- "installation directory for documentation"- docdir (\v flags -> flags { docdir = v })- installDirArg-- , option "" ["htmldir"]- "installation directory for HTML documentation"- htmldir (\v flags -> flags { htmldir = v })- installDirArg-- , option "" ["haddockdir"]- "installation directory for haddock interfaces"- haddockdir (\v flags -> flags { haddockdir = v })- installDirArg- ]- where- installDirArg _sf _lf d get set =- reqArgFlag "DIR" _sf _lf d- (fmap fromPathTemplate . get) (set . fmap toPathTemplate)-- reqArgFlag ad = reqArg ad (fmap toFlag (readP_to_E err parseFilePathQ))- (map (show . showFilePath) . flagToList)- where err _ = "paths with spaces must use Haskell String syntax"
Distribution/Client/Configure.hs view
@@ -14,16 +14,7 @@ configure, ) where -import Data.Monoid- ( Monoid(mempty) )-import qualified Data.Map as Map- import Distribution.Client.Dependency- ( resolveDependenciesWithProgress- , PackageConstraint(..)- , PackagesPreference(..), PackagesPreferenceDefault(..)- , PackagePreference(..)- , Progress(..), foldProgress, ) import qualified Distribution.Client.InstallPlan as InstallPlan import Distribution.Client.InstallPlan (InstallPlan) import Distribution.Client.IndexUtils as IndexUtils@@ -31,8 +22,6 @@ import Distribution.Client.Setup ( ConfigExFlags(..), configureCommand, filterConfigureFlags ) import Distribution.Client.Types as Available- ( AvailablePackage(..), AvailablePackageSource(..), Repo(..)- , AvailablePackageDb(..), ConfiguredPackage(..), InstalledPackage ) import Distribution.Client.SetupWrapper ( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions ) @@ -42,21 +31,19 @@ import Distribution.Simple.Program (ProgramConfiguration ) import Distribution.Simple.Setup ( ConfigFlags(..), toFlag, flagToMaybe, fromFlagOrDefault )-import qualified Distribution.Client.PackageIndex as PackageIndex import Distribution.Client.PackageIndex (PackageIndex) import Distribution.Simple.Utils ( defaultPackageDesc ) import Distribution.Package- ( PackageName, packageName, packageVersion- , Package(..), Dependency(..), thisPackageVersion )+ ( Package(..), packageName, Dependency(..), thisPackageVersion ) import Distribution.PackageDescription.Parse ( readPackageDescription ) import Distribution.PackageDescription.Configuration ( finalizePackageDescription ) import Distribution.Version- ( VersionRange, anyVersion, thisVersion )+ ( anyVersion, thisVersion ) import Distribution.Simple.Utils as Utils- ( notice, info, die )+ ( notice, info, debug, die ) import Distribution.System ( Platform, buildPlatform ) import Distribution.Verbosity as Verbosity@@ -82,8 +69,8 @@ installed available notice verbosity "Resolving dependencies..."- maybePlan <- foldProgress (\message rest -> info verbosity message >> rest)- (return . Left) (return . Right) progress+ maybePlan <- foldProgress logMsg (return . Left) (return . Right)+ progress case maybePlan of Left message -> do info verbosity message@@ -91,7 +78,7 @@ configureCommand (const configFlags) extraArgs Right installPlan -> case InstallPlan.ready installPlan of- [pkg@(ConfiguredPackage (AvailablePackage _ _ LocalUnpackedPackage) _ _)] ->+ [pkg@(ConfiguredPackage (AvailablePackage _ _ (LocalUnpackedPackage _)) _ _)] -> configurePackage verbosity (InstallPlan.planPlatform installPlan) (InstallPlan.planCompiler installPlan)@@ -113,7 +100,7 @@ then packageDBs else packageDBs ++ [UserPackageDB], usePackageIndex = if UserPackageDB `elem` packageDBs- then index+ then Just index else Nothing, useProgramConfig = conf, useDistPref = fromFlagOrDefault@@ -123,54 +110,49 @@ useWorkingDir = Nothing } + logMsg message rest = debug verbosity message >> rest+ -- | Make an 'InstallPlan' for the unpacked package in the current directory, -- and all its dependencies. -- planLocalPackage :: Verbosity -> Compiler -> ConfigFlags -> ConfigExFlags- -> Maybe (PackageIndex InstalledPackage)+ -> PackageIndex InstalledPackage -> AvailablePackageDb -> IO (Progress String String InstallPlan) planLocalPackage verbosity comp configFlags configExFlags installed- (AvailablePackageDb _ availablePrefs) = do+ availabledb = do pkg <- readPackageDescription verbosity =<< defaultPackageDesc verbosity- let -- The trick is, we add the local package to the available index and- -- remove it from the installed index. Then we ask to resolve a- -- dependency on exactly that package. So the resolver ends up having- -- to pick the local package.- available' = PackageIndex.insert localPkg mempty- installed' = PackageIndex.deletePackageId (packageId localPkg) `fmap` installed++ let -- We create a local package and ask to resolve a dependency on it localPkg = AvailablePackage { packageInfoId = packageId pkg, Available.packageDescription = pkg,- packageSource = LocalUnpackedPackage+ packageSource = LocalUnpackedPackage "." }- targets = [packageName pkg]- constraints = [PackageVersionConstraint (packageName pkg)- (thisVersion (packageVersion pkg))- ,PackageFlagsConstraint (packageName pkg)- (configConfigurationsFlags configFlags)]- ++ [ PackageVersionConstraint name ver- | Dependency name ver <- configConstraints configFlags ]- preferences = mergePackagePrefs PreferLatestForSelected- availablePrefs configExFlags - return $ resolveDependenciesWithProgress buildPlatform (compilerId comp)- installed' available' preferences constraints targets+ resolverParams = + addPreferences+ -- preferences from the config file or command line+ [ PackageVersionPreference name ver+ | Dependency name ver <- configPreferences configExFlags ] -mergePackagePrefs :: PackagesPreferenceDefault- -> Map.Map PackageName VersionRange- -> ConfigExFlags- -> PackagesPreference-mergePackagePrefs defaultPref availablePrefs configExFlags =- PackagesPreference defaultPref $- -- The preferences that come from the hackage index- [ PackageVersionPreference name ver- | (name, ver) <- Map.toList availablePrefs ]- -- additional preferences from the config file or command line- ++ [ PackageVersionPreference name ver- | Dependency name ver <- configPreferences configExFlags ]+ . addConstraints+ -- version constraints from the config file or command line+ [ PackageVersionConstraint name ver+ | Dependency name ver <- configConstraints configFlags ]++ . addConstraints+ -- package flags from the config file or command line+ [ PackageFlagsConstraint (packageName pkg)+ (configConfigurationsFlags configFlags) ]++ $ standardInstallPolicy installed availabledb+ [SpecificSourcePackage localPkg]++ return (resolveDependencies buildPlatform (compilerId comp) resolverParams)+ -- | Call an installer for an 'AvailablePackage' but override the configure -- flags with the ones given by the 'ConfiguredPackage'. In particular the
Distribution/Client/Dependency.hs view
@@ -13,75 +13,91 @@ -- Top level interface to dependency resolution. ----------------------------------------------------------------------------- module Distribution.Client.Dependency (- module Distribution.Client.Dependency.Types,+ -- * The main package dependency resolver resolveDependencies,- resolveDependenciesWithProgress,+ Progress(..),+ foldProgress, - dependencyConstraints,- dependencyTargets,+ -- * Alternate, simple resolver that does not do dependencies recursively+ resolveWithoutDependencies, - PackagesPreference(..),+ -- * Constructing resolver policies+ DepResolverParams(..),+ PackageConstraint(..), PackagesPreferenceDefault(..), PackagePreference(..),+ InstalledPreference(..), - upgradableDependencies,+ -- ** Standard policy+ standardInstallPolicy,+ PackageSpecifier(..),++ -- ** Extra policy options+ dontUpgradeBasePackage,+ hideBrokenInstalledPackages,+ upgradeDependencies,+ reinstallTargets,++ -- ** Policy utils+ addConstraints,+ addPreferences,+ setPreferenceDefault,+ addAvailablePackages,+ hideInstalledPackagesSpecific,+ hideInstalledPackagesAllVersions, ) where -import Distribution.Client.Dependency.Bogus (bogusResolver) import Distribution.Client.Dependency.TopDown (topDownResolver) import qualified Distribution.Client.PackageIndex as PackageIndex import Distribution.Client.PackageIndex (PackageIndex) import qualified Distribution.Client.InstallPlan as InstallPlan import Distribution.Client.InstallPlan (InstallPlan) import Distribution.Client.Types- ( UnresolvedDependency(..), AvailablePackage(..), InstalledPackage )+ ( AvailablePackageDb(AvailablePackageDb)+ , AvailablePackage(..), InstalledPackage ) import Distribution.Client.Dependency.Types ( DependencyResolver, PackageConstraint(..) , PackagePreferences(..), InstalledPreference(..) , Progress(..), foldProgress )+import Distribution.Client.Targets import Distribution.Package- ( PackageIdentifier(..), PackageName(..), packageVersion, packageName- , Dependency(..), Package(..), PackageFixedDeps(..) )+ ( PackageName(..), PackageId, Package(..), packageVersion+ , Dependency(Dependency)) import Distribution.Version- ( VersionRange, anyVersion, orLaterVersion, isAnyVersion )+ ( VersionRange, anyVersion, withinRange, simplifyVersionRange ) import Distribution.Compiler ( CompilerId(..) ) import Distribution.System ( Platform ) import Distribution.Simple.Utils (comparing)-import Distribution.Client.Utils (mergeBy, MergeResult(..))+import Distribution.Text+ ( display ) -import Data.List (maximumBy)-import Data.Monoid (Monoid(mempty))-import Data.Maybe (fromMaybe)+import Data.List (maximumBy, foldl')+import Data.Maybe (fromMaybe, isJust) import qualified Data.Map as Map import qualified Data.Set as Set import Data.Set (Set)-import Control.Exception (assert) -defaultResolver :: DependencyResolver-defaultResolver = topDownResolver --- | Global policy for the versions of all packages.+-- ------------------------------------------------------------+-- * High level planner policy+-- ------------------------------------------------------------++-- | The set of parameters to the dependency resolver. These parameters are+-- relatively low level but many kinds of high level policies can be+-- implemented in terms of adjustments to the parameters. ---data PackagesPreference = PackagesPreference- PackagesPreferenceDefault- [PackagePreference]+data DepResolverParams = DepResolverParams {+ depResolverTargets :: [PackageName],+ depResolverConstraints :: [PackageConstraint],+ depResolverPreferences :: [PackagePreference],+ depResolverPreferenceDefault :: PackagesPreferenceDefault,+ depResolverInstalled :: PackageIndex InstalledPackage,+ depResolverAvailable :: PackageIndex AvailablePackage+ } -dependencyConstraints :: [UnresolvedDependency] -> [PackageConstraint]-dependencyConstraints deps =- [ PackageVersionConstraint name versionRange- | UnresolvedDependency (Dependency name versionRange) _ <- deps- , not (isAnyVersion versionRange) ] - ++ [ PackageFlagsConstraint name flags- | UnresolvedDependency (Dependency name _) flags <- deps- , not (null flags) ]--dependencyTargets :: [UnresolvedDependency] -> [PackageName]-dependencyTargets deps =- [ name | UnresolvedDependency (Dependency name _) _ <- deps ]- -- | Global policy for all packages to say if we prefer package versions that -- are already installed locally or if we just prefer the latest available. --@@ -106,90 +122,217 @@ -- | PreferLatestForSelected -data PackagePreference- = PackageVersionPreference PackageName VersionRange++-- | A package selection preference for a particular package.+--+-- Preferences are soft constraints that the dependency resolver should try to+-- respect where possible. It is not specified if preferences on some packages+-- are more important than others.+--+data PackagePreference =++ -- | A suggested constraint on the version number.+ PackageVersionPreference PackageName VersionRange++ -- | If we prefer versions of packages that are already installed. | PackageInstalledPreference PackageName InstalledPreference +basicDepResolverParams :: PackageIndex InstalledPackage+ -> PackageIndex AvailablePackage+ -> DepResolverParams+basicDepResolverParams installed available =+ DepResolverParams {+ depResolverTargets = [],+ depResolverConstraints = [],+ depResolverPreferences = [],+ depResolverPreferenceDefault = PreferLatestForSelected,+ depResolverInstalled = installed,+ depResolverAvailable = available+ }++addTargets :: [PackageName]+ -> DepResolverParams -> DepResolverParams+addTargets extraTargets params =+ params {+ depResolverTargets = extraTargets ++ depResolverTargets params+ }++addConstraints :: [PackageConstraint]+ -> DepResolverParams -> DepResolverParams+addConstraints extraConstraints params =+ params {+ depResolverConstraints = extraConstraints+ ++ depResolverConstraints params+ }++addPreferences :: [PackagePreference]+ -> DepResolverParams -> DepResolverParams+addPreferences extraPreferences params =+ params {+ depResolverPreferences = extraPreferences+ ++ depResolverPreferences params+ }++setPreferenceDefault :: PackagesPreferenceDefault+ -> DepResolverParams -> DepResolverParams+setPreferenceDefault preferenceDefault params =+ params {+ depResolverPreferenceDefault = preferenceDefault+ }++dontUpgradeBasePackage :: DepResolverParams -> DepResolverParams+dontUpgradeBasePackage params =+ addConstraints extraConstraints params+ where+ extraConstraints =+ [ PackageInstalledConstraint pkgname+ | all (/=PackageName "base") (depResolverTargets params)+ , pkgname <- [ PackageName "base", PackageName "ghc-prim" ]+ , isInstalled pkgname ]+ -- TODO: the top down resolver chokes on the base constraints+ -- below when there are no targets and thus no dep on base.+ -- Need to refactor contraints separate from needing packages.+ isInstalled = not . null+ . PackageIndex.lookupPackageName (depResolverInstalled params)++addAvailablePackages :: [AvailablePackage]+ -> DepResolverParams -> DepResolverParams+addAvailablePackages pkgs params =+ params {+ depResolverAvailable = foldl (flip PackageIndex.insert)+ (depResolverAvailable params) pkgs+ }++hideInstalledPackagesSpecific :: [PackageId]+ -> DepResolverParams -> DepResolverParams+hideInstalledPackagesSpecific pkgids params =+ --TODO: this should work using exclude constraints instead+ params {+ depResolverInstalled = foldl' (flip PackageIndex.deletePackageId)+ (depResolverInstalled params) pkgids+ }++hideInstalledPackagesAllVersions :: [PackageName]+ -> DepResolverParams -> DepResolverParams+hideInstalledPackagesAllVersions pkgnames params =+ --TODO: this should work using exclude constraints instead+ params {+ depResolverInstalled =+ foldl' (flip PackageIndex.deletePackageName)+ (depResolverInstalled params) pkgnames+ }+++hideBrokenInstalledPackages :: DepResolverParams -> DepResolverParams+hideBrokenInstalledPackages params =+ hideInstalledPackagesSpecific pkgids params+ where+ pkgids = map packageId+ . PackageIndex.reverseDependencyClosure (depResolverInstalled params)+ . map (packageId . fst)+ . PackageIndex.brokenPackages+ $ depResolverInstalled params+++upgradeDependencies :: DepResolverParams -> DepResolverParams+upgradeDependencies = setPreferenceDefault PreferAllLatest+++reinstallTargets :: DepResolverParams -> DepResolverParams+reinstallTargets params =+ hideInstalledPackagesAllVersions (depResolverTargets params) params+++standardInstallPolicy :: PackageIndex InstalledPackage+ -> AvailablePackageDb+ -> [PackageSpecifier AvailablePackage]+ -> DepResolverParams+standardInstallPolicy+ installed (AvailablePackageDb available availablePrefs) pkgSpecifiers++ = addPreferences+ [ PackageVersionPreference name ver+ | (name, ver) <- Map.toList availablePrefs ]++ . addConstraints+ (concatMap pkgSpecifierConstraints pkgSpecifiers)++ . addTargets+ (map pkgSpecifierTarget pkgSpecifiers)++ . hideInstalledPackagesSpecific+ [ packageId pkg | SpecificSourcePackage pkg <- pkgSpecifiers ]++ . addAvailablePackages+ [ pkg | SpecificSourcePackage pkg <- pkgSpecifiers ]++ $ basicDepResolverParams+ installed available+++-- ------------------------------------------------------------+-- * Interface to the standard resolver+-- ------------------------------------------------------------++defaultResolver :: DependencyResolver+defaultResolver = topDownResolver++-- | Run the dependency solver.+--+-- Since this is potentially an expensive operation, the result is wrapped in a+-- a 'Progress' structure that can be unfolded to provide progress information,+-- logging messages and the final result or an error.+-- resolveDependencies :: Platform -> CompilerId- -> Maybe (PackageIndex InstalledPackage)- -> PackageIndex AvailablePackage- -> PackagesPreference- -> [PackageConstraint]- -> [PackageName]- -> Either String InstallPlan-resolveDependencies platform comp installed available- preferences constraints targets =- foldProgress (flip const) Left Right $- resolveDependenciesWithProgress platform comp installed available- preferences constraints targets+ -> DepResolverParams+ -> Progress String String InstallPlan -resolveDependenciesWithProgress :: Platform- -> CompilerId- -> Maybe (PackageIndex InstalledPackage)- -> PackageIndex AvailablePackage- -> PackagesPreference- -> [PackageConstraint]- -> [PackageName]- -> Progress String String InstallPlan-resolveDependenciesWithProgress platform comp (Just installed) =- dependencyResolver defaultResolver platform comp installed+ --TODO: is this needed here? see dontUpgradeBasePackage+resolveDependencies platform comp params+ | null (depResolverTargets params)+ = return (mkInstallPlan platform comp []) -resolveDependenciesWithProgress platform comp Nothing =- dependencyResolver bogusResolver platform comp mempty+resolveDependencies platform comp params = -hideBrokenPackages :: PackageFixedDeps p => PackageIndex p -> PackageIndex p-hideBrokenPackages index =- check (null . PackageIndex.brokenPackages)- . foldr (PackageIndex.deletePackageId . packageId) index- . PackageIndex.reverseDependencyClosure index- . map (packageId . fst)- $ PackageIndex.brokenPackages index+ fmap (mkInstallPlan platform comp)+ $ defaultResolver platform comp installed available+ preferences constraints targets where- check p x = assert (p x) x+ DepResolverParams+ targets constraints+ prefs defpref+ installed available = dontUpgradeBasePackage+ . hideBrokenInstalledPackages+ $ params -dependencyResolver- :: DependencyResolver- -> Platform -> CompilerId- -> PackageIndex InstalledPackage- -> PackageIndex AvailablePackage- -> PackagesPreference- -> [PackageConstraint]- -> [PackageName]- -> Progress String String InstallPlan-dependencyResolver resolver platform comp installed available- pref constraints targets =- let installed' = hideBrokenPackages installed- -- If the user is not explicitly asking to upgrade base then lets- -- prevent that from happening accidentally since it is usually not what- -- you want and it probably does not work anyway. We do it by adding a- -- constraint to only pick an installed version of base and ghc-prim.- extraConstraints =- [ PackageInstalledConstraint pkgname- | all (/=PackageName "base") targets- , pkgname <- [ PackageName "base", PackageName "ghc-prim" ]- , not (null (PackageIndex.lookupPackageName installed pkgname)) ]- preferences = interpretPackagesPreference (Set.fromList targets) pref- in fmap toPlan- $ resolver platform comp installed' available- preferences (extraConstraints ++ constraints) targets+ preferences = interpretPackagesPreference+ (Set.fromList targets) defpref prefs - where- toPlan pkgs =- case InstallPlan.new platform comp (PackageIndex.fromList pkgs) of- Right plan -> plan- Left problems -> error $ unlines $- "internal error: could not construct a valid install plan."- : "The proposed (invalid) plan contained the following problems:"- : map InstallPlan.showPlanProblem problems +-- | Make an install plan from the output of the dep resolver.+-- It checks that the plan is valid, or it's an error in the dep resolver.+--+mkInstallPlan :: Platform+ -> CompilerId+ -> [InstallPlan.PlanPackage] -> InstallPlan+mkInstallPlan platform comp pkgs =+ case InstallPlan.new platform comp (PackageIndex.fromList pkgs) of+ Right plan -> plan+ Left problems -> error $ unlines $+ "internal error: could not construct a valid install plan."+ : "The proposed (invalid) plan contained the following problems:"+ : map InstallPlan.showPlanProblem problems++ -- | Give an interpretation to the global 'PackagesPreference' as -- specific per-package 'PackageVersionPreference'. -- interpretPackagesPreference :: Set PackageName- -> PackagesPreference+ -> PackagesPreferenceDefault+ -> [PackagePreference] -> (PackageName -> PackagePreferences)-interpretPackagesPreference selected (PackagesPreference defaultPref prefs) =+interpretPackagesPreference selected defaultPref prefs = \pkgname -> PackagePreferences (versionPref pkgname) (installPref pkgname) where@@ -213,21 +356,86 @@ if pkgname `Set.member` selected then PreferLatest else PreferInstalled --- | Given the list of installed packages and available packages, figure--- out which packages can be upgraded.+-- ------------------------------------------------------------+-- * Simple resolver that ignores dependencies+-- ------------------------------------------------------------++-- | A simplistic method of resolving a list of target package names to+-- available packages. ---upgradableDependencies :: PackageIndex InstalledPackage- -> PackageIndex AvailablePackage- -> [Dependency]-upgradableDependencies installed available =- [ Dependency name (orLaterVersion latestVersion)- -- This is really quick (linear time). The trick is that we're doing a- -- merge join of two tables. We can do it as a merge because they're in- -- a comparable order because we're getting them from the package indexs.- | InBoth latestInstalled allAvailable- <- mergeBy (\a (b:_) -> packageName a `compare` packageName b)- [ maximumBy (comparing packageVersion) pkgs- | pkgs <- PackageIndex.allPackagesByName installed ]- (PackageIndex.allPackagesByName available)- , let (PackageIdentifier name latestVersion) = packageId latestInstalled- , any (\p -> packageVersion p > latestVersion) allAvailable ]+-- Specifically, it does not consider package dependencies at all. Unlike+-- 'resolveDependencies', no attempt is made to ensure that the selected+-- packages have dependencies that are satisfiable or consistent with+-- each other.+--+-- It is suitable for tasks such as selecting packages to download for user+-- inspection. It is not suitable for selecting packages to install.+--+-- Note: if no installed package index is available, it is ok to pass 'mempty'.+-- It simply means preferences for installed packages will be ignored.+--+resolveWithoutDependencies :: DepResolverParams+ -> Either [ResolveNoDepsError] [AvailablePackage]+resolveWithoutDependencies (DepResolverParams targets constraints+ prefs defpref installed available) =+ collectEithers (map selectPackage targets)+ where+ selectPackage :: PackageName -> Either ResolveNoDepsError AvailablePackage+ selectPackage pkgname+ | null choices = Left $! ResolveUnsatisfiable pkgname requiredVersions+ | otherwise = Right $! maximumBy bestByPrefs choices++ where+ -- Constraints+ requiredVersions = packageConstraints pkgname+ pkgDependency = Dependency pkgname requiredVersions+ choices = PackageIndex.lookupDependency available pkgDependency++ -- Preferences+ PackagePreferences preferredVersions preferInstalled+ = packagePreferences pkgname++ bestByPrefs = comparing $ \pkg ->+ (installPref pkg, versionPref pkg, packageVersion pkg)+ installPref = case preferInstalled of+ PreferLatest -> const False+ PreferInstalled -> isJust . PackageIndex.lookupPackageId installed+ . packageId+ versionPref pkg = packageVersion pkg `withinRange` preferredVersions++ packageConstraints :: PackageName -> VersionRange+ packageConstraints pkgname =+ Map.findWithDefault anyVersion pkgname packageVersionConstraintMap+ packageVersionConstraintMap =+ Map.fromList [ (name, range)+ | PackageVersionConstraint name range <- constraints ]++ packagePreferences :: PackageName -> PackagePreferences+ packagePreferences = interpretPackagesPreference+ (Set.fromList targets) defpref prefs+++collectEithers :: [Either a b] -> Either [a] [b]+collectEithers = collect . partitionEithers+ where+ collect ([], xs) = Right xs+ collect (errs,_) = Left errs+ partitionEithers :: [Either a b] -> ([a],[b])+ partitionEithers = foldr (either left right) ([],[])+ where+ left a (l, r) = (a:l, r)+ right a (l, r) = (l, a:r)++-- | Errors for 'resolveWithoutDependencies'.+--+data ResolveNoDepsError =++ -- | A package name which cannot be resolved to a specific package.+ -- Also gives the constraint on the version and whether there was+ -- a constraint on the package being installed.+ ResolveUnsatisfiable PackageName VersionRange++instance Show ResolveNoDepsError where+ show (ResolveUnsatisfiable name ver) =+ "There is no available version of " ++ display name+ ++ " that satisfies " ++ display (simplifyVersionRange ver)
− Distribution/Client/Dependency/Bogus.hs
@@ -1,129 +0,0 @@--------------------------------------------------------------------------------- |--- Module : Distribution.Client.Dependency.Bogus--- Copyright : (c) David Himmelstrup 2005, Bjorn Bringert 2007--- Duncan Coutts 2008--- License : BSD-like------ Maintainer : cabal-devel@haskell.org--- Stability : provisional--- Portability : portable------ A dependency resolver for when we do not know what packages are installed.-------------------------------------------------------------------------------module Distribution.Client.Dependency.Bogus (- bogusResolver- ) where--import Distribution.Client.Types- ( AvailablePackage(..), ConfiguredPackage(..) )-import Distribution.Client.Dependency.Types- ( DependencyResolver, Progress(..)- , PackageConstraint(..), PackagePreferences(..) )-import qualified Distribution.Client.InstallPlan as InstallPlan--import Distribution.Package- ( PackageName, PackageIdentifier(..), Dependency(..)- , Package(..), packageVersion )-import Distribution.PackageDescription- ( GenericPackageDescription(..), CondTree(..), FlagAssignment )-import Distribution.PackageDescription.Configuration- ( finalizePackageDescription )-import qualified Distribution.Client.PackageIndex as PackageIndex-import Distribution.Client.PackageIndex (PackageIndex)-import Distribution.Version- ( VersionRange, anyVersion, intersectVersionRanges, withinRange )-import Distribution.Simple.Utils- ( comparing )-import Distribution.Text- ( display )--import Data.List- ( maximumBy )-import Data.Maybe- ( fromMaybe )-import qualified Data.Map as Map---- | This resolver thinks that every package is already installed.------ We need this for hugs and nhc98 which do not track installed packages.--- We just pretend that everything is installed and hope for the best.----bogusResolver :: DependencyResolver-bogusResolver platform comp _ available- preferences constraints targets =- resolveFromAvailable []- (combineConstraints preferences constraints targets)- where- resolveFromAvailable chosen [] = Done chosen- resolveFromAvailable chosen ((name, verConstraint, flags, verPref): deps) =- case latestAvailableSatisfying available name verConstraint verPref of- Nothing -> Fail ("Unresolved dependency: " ++ display dep)- Just apkg@(AvailablePackage _ pkg _) ->- case finalizePackageDescription flags none platform comp [] pkg of- Right (_, flags') -> Step msg (resolveFromAvailable chosen' deps)- where- msg = "selecting " ++ display (packageId pkg)- cpkg = fudgeChosenPackage apkg flags'- chosen' = InstallPlan.Configured cpkg : chosen- _ -> error "bogusResolver: impossible happened"- where- none :: Dependency -> Bool- none = const True- where- dep = Dependency name verConstraint--fudgeChosenPackage :: AvailablePackage -> FlagAssignment -> ConfiguredPackage-fudgeChosenPackage (AvailablePackage pkgid pkg source) flags =- ConfiguredPackage (AvailablePackage pkgid (stripDependencies pkg) source)- flags ([] :: [PackageIdentifier]) -- empty list of deps- where- -- | Pretend that a package has no dependencies. Go through the- -- 'GenericPackageDescription' and strip them all out.- --- stripDependencies :: GenericPackageDescription -> GenericPackageDescription- stripDependencies gpkg = gpkg {- condLibrary = fmap stripDeps (condLibrary gpkg),- condExecutables = [ (name, stripDeps tree)- | (name, tree) <- condExecutables gpkg ]- }- stripDeps :: CondTree v [Dependency] a -> CondTree v [Dependency] a- stripDeps = mapTreeConstrs (const [])-- mapTreeConstrs :: (c -> c) -> CondTree v c a -> CondTree v c a- mapTreeConstrs f (CondNode a c ifs) = CondNode a (f c) (map g ifs)- where- g (cnd, t, me) = (cnd, mapTreeConstrs f t, fmap (mapTreeConstrs f) me)--combineConstraints :: (PackageName -> PackagePreferences)- -> [PackageConstraint]- -> [PackageName]- -> [(PackageName, VersionRange, FlagAssignment, VersionRange)]-combineConstraints preferences constraints targets =- [ (name, ver, flags, pref)- | name <- targets- , let ver = fromMaybe anyVersion (Map.lookup name versionConstraints)- flags = fromMaybe [] (Map.lookup name flagsConstraints)- PackagePreferences pref _ = preferences name ]- where- versionConstraints = Map.fromListWith intersectVersionRanges- [ (name, versionRange)- | PackageVersionConstraint name versionRange <- constraints ]-- flagsConstraints = Map.fromListWith (++)- [ (name, flags)- | PackageFlagsConstraint name flags <- constraints ]---- | Gets the best available package satisfying a dependency.----latestAvailableSatisfying :: PackageIndex AvailablePackage- -> PackageName -> VersionRange -> VersionRange- -> Maybe AvailablePackage-latestAvailableSatisfying index name versionConstraint versionPreference =- case PackageIndex.lookupDependency index dep of- [] -> Nothing- pkgs -> Just (maximumBy best pkgs)- where- dep = Dependency name versionConstraint- best = comparing (\p -> (isPreferred p, packageVersion p))- isPreferred p = packageVersion p `withinRange` versionPreference
Distribution/Client/Dependency/TopDown.hs view
@@ -467,7 +467,7 @@ Nothing -> \_ -> False Just ipkg -> \p -> packageId p `elem` depends ipkg -- If there is no upper bound on the version range then we apply a- -- preferred version acording to the hackage or user's suggested+ -- preferred version according to the hackage or user's suggested -- version constraints. TODO: distinguish hacks from prefs bounded = boundedAbove versionRange isPreferred p
Distribution/Client/Dependency/TopDown/Constraints.hs view
@@ -4,7 +4,7 @@ -- Copyright : (c) Duncan Coutts 2008 -- License : BSD-like ----- Maintainer : duncan@haskell.org+-- Maintainer : duncan@community.haskell.org -- Stability : provisional -- Portability : portable --
Distribution/Client/Dependency/Types.hs view
@@ -66,6 +66,7 @@ = PackageVersionConstraint PackageName VersionRange | PackageInstalledConstraint PackageName | PackageFlagsConstraint PackageName FlagAssignment+ deriving (Show,Eq) -- | A per-package preference on the version. It is a soft constraint that the -- 'DependencyResolver' should try to respect where possible. It consists of
Distribution/Client/Fetch.hs view
@@ -2,52 +2,40 @@ -- | -- Module : Distribution.Client.Fetch -- Copyright : (c) David Himmelstrup 2005+-- Duncan Coutts 2011 -- License : BSD-like ----- Maintainer : lemmih@gmail.com+-- Maintainer : cabal-devel@gmail.com -- Stability : provisional -- Portability : portable -----+-- The cabal fetch command ----------------------------------------------------------------------------- module Distribution.Client.Fetch (-- -- * Commands fetch,-- -- * Utilities- fetchPackage,- isFetched,- downloadIndex, ) where import Distribution.Client.Types- ( UnresolvedDependency (..), AvailablePackage(..)- , AvailablePackageSource(..), AvailablePackageDb(..)- , Repo(..), RemoteRepo(..), LocalRepo(..) )+import Distribution.Client.Targets+import Distribution.Client.FetchUtils hiding (fetchPackage) import Distribution.Client.Dependency- ( resolveDependenciesWithProgress- , dependencyConstraints, dependencyTargets- , PackagesPreference(..), PackagesPreferenceDefault(..)- , PackagePreference(..) )-import Distribution.Client.Dependency.Types- ( foldProgress )+import Distribution.Client.PackageIndex (PackageIndex) import Distribution.Client.IndexUtils as IndexUtils- ( getAvailablePackages, disambiguateDependencies- , getInstalledPackages )+ ( getAvailablePackages, getInstalledPackages ) import qualified Distribution.Client.InstallPlan as InstallPlan-import Distribution.Client.HttpUtils- ( downloadURI, isOldHackageURI )+import Distribution.Client.Setup+ ( GlobalFlags(..), FetchFlags(..) ) import Distribution.Package- ( PackageIdentifier, packageName, packageVersion, Dependency(..) )-import qualified Distribution.Client.PackageIndex as PackageIndex+ ( packageId ) import Distribution.Simple.Compiler ( Compiler(compilerId), PackageDBStack ) import Distribution.Simple.Program ( ProgramConfiguration )+import Distribution.Simple.Setup+ ( fromFlag ) import Distribution.Simple.Utils- ( die, notice, info, debug, setupMessage )+ ( die, notice, debug ) import Distribution.System ( buildPlatform ) import Distribution.Text@@ -55,138 +43,129 @@ import Distribution.Verbosity ( Verbosity ) -import qualified Data.Map as Map import Control.Monad- ( when, filterM )-import System.Directory- ( doesFileExist, createDirectoryIfMissing )-import System.FilePath- ( (</>), (<.>) )-import qualified System.FilePath.Posix as FilePath.Posix- ( combine, joinPath )-import Network.URI- ( URI(uriPath) )+ ( filterM ) +-- ------------------------------------------------------------+-- * The fetch command+-- ------------------------------------------------------------ --- Downloads a package to [config-dir/packages/package-id] and returns the path to the package.-downloadPackage :: Verbosity -> Repo -> PackageIdentifier -> IO String-downloadPackage _ repo@Repo{ repoKind = Right LocalRepo } pkgid =- return (packageFile repo pkgid)+--TODO:+-- * add fetch -o support+-- * support tarball URLs via ad-hoc download cache (or in -o mode?)+-- * suggest using --no-deps, unpack or fetch -o if deps cannot be satisfied+-- * Port various flags from install:+-- * --updage-dependencies+-- * --constraint and --preference+-- * --only-dependencies, but note it conflicts with --no-deps -downloadPackage verbosity repo@Repo{ repoKind = Left remoteRepo } pkgid = do- let uri = packageURI remoteRepo pkgid- dir = packageDir repo pkgid- path = packageFile repo pkgid- debug verbosity $ "GET " ++ show uri- createDirectoryIfMissing True dir- downloadURI verbosity uri path- return path --- Downloads an index file to [config-dir/packages/serv-id].-downloadIndex :: Verbosity -> RemoteRepo -> FilePath -> IO FilePath-downloadIndex verbosity repo cacheDir = do- let uri = (remoteRepoURI repo) {- uriPath = uriPath (remoteRepoURI repo)- `FilePath.Posix.combine` "00-index.tar.gz"- }- path = cacheDir </> "00-index" <.> "tar.gz"- createDirectoryIfMissing True cacheDir- downloadURI verbosity uri path- return path---- |Returns @True@ if the package has already been fetched.-isFetched :: AvailablePackage -> IO Bool-isFetched (AvailablePackage pkgid _ source) = case source of- LocalUnpackedPackage -> return True- RepoTarballPackage repo -> doesFileExist (packageFile repo pkgid)---- |Fetch a package if we don't have it already.-fetchPackage :: Verbosity -> Repo -> PackageIdentifier -> IO String-fetchPackage verbosity repo pkgid = do- fetched <- doesFileExist (packageFile repo pkgid)- if fetched- then do info verbosity $ display pkgid ++ " has already been downloaded."- return (packageFile repo pkgid)- else do setupMessage verbosity "Downloading" pkgid- downloadPackage verbosity repo pkgid---- |Fetch a list of packages and their dependencies.+-- | Fetch a list of packages and their dependencies.+-- fetch :: Verbosity -> PackageDBStack -> [Repo] -> Compiler -> ProgramConfiguration- -> [UnresolvedDependency]+ -> GlobalFlags+ -> FetchFlags+ -> [UserTarget] -> IO ()-fetch verbosity packageDBs repos comp conf deps = do- installed <- getInstalledPackages verbosity comp packageDBs conf- AvailablePackageDb available availablePrefs- <- getAvailablePackages verbosity repos- deps' <- IndexUtils.disambiguateDependencies available deps+fetch verbosity _ _ _ _ _ _ [] =+ notice verbosity "No packages requested. Nothing to do." - let -- Hide the packages given on the command line so that the dep resolver- -- will decide that they need fetching, even if they're already- -- installed. Sicne we want to get the source packages of things we might- -- have installed (but not have the sources for).- installed' = fmap (hideGivenDeps deps') installed- hideGivenDeps pkgs index =- foldr PackageIndex.deletePackageName index- [ name | UnresolvedDependency (Dependency name _) _ <- pkgs ]+fetch verbosity packageDBs repos comp conf+ globalFlags fetchFlags userTargets = do - let progress = resolveDependenciesWithProgress- buildPlatform (compilerId comp)- installed' available- (PackagesPreference PreferLatestForSelected- [ PackageVersionPreference name ver- | (name, ver) <- Map.toList availablePrefs ])- (dependencyConstraints deps')- (dependencyTargets deps')- notice verbosity "Resolving dependencies..."- maybePlan <- foldProgress (\message rest -> info verbosity message >> rest)- (return . Left) (return . Right) progress- case maybePlan of- Left message -> die message- Right pkgs -> do- ps <- filterM (fmap not . isFetched)- [ pkg | (InstallPlan.Configured- (InstallPlan.ConfiguredPackage pkg _ _))- <- InstallPlan.toList pkgs ]- when (null ps) $- notice verbosity $ "No packages need to be fetched. "- ++ "All the requested packages are already cached."+ mapM_ checkTarget userTargets - sequence_ - [ fetchPackage verbosity repo pkgid- | (AvailablePackage pkgid _ (RepoTarballPackage repo)) <- ps ]+ installed <- getInstalledPackages verbosity comp packageDBs conf+ availableDb <- getAvailablePackages verbosity repos --- |Generate the full path to the locally cached copy of--- the tarball for a given @PackageIdentifer@.-packageFile :: Repo -> PackageIdentifier -> FilePath-packageFile repo pkgid = packageDir repo pkgid- </> display pkgid- <.> "tar.gz"+ pkgSpecifiers <- resolveUserTargets verbosity+ globalFlags (packageIndex availableDb) userTargets --- |Generate the full path to the directory where the local cached copy of--- the tarball for a given @PackageIdentifer@ is stored.-packageDir :: Repo -> PackageIdentifier -> FilePath-packageDir repo pkgid = repoLocalDir repo- </> display (packageName pkgid)- </> display (packageVersion pkgid)+ pkgs <- planPackages+ verbosity comp fetchFlags+ installed availableDb pkgSpecifiers --- | Generate the URI of the tarball for a given package.-packageURI :: RemoteRepo -> PackageIdentifier -> URI-packageURI repo pkgid | isOldHackageURI (remoteRepoURI repo) =- (remoteRepoURI repo) {- uriPath = FilePath.Posix.joinPath- [uriPath (remoteRepoURI repo)- ,display (packageName pkgid)- ,display (packageVersion pkgid)- ,display pkgid <.> "tar.gz"]- }-packageURI repo pkgid =- (remoteRepoURI repo) {- uriPath = FilePath.Posix.joinPath- [uriPath (remoteRepoURI repo)- ,"package"- ,display pkgid <.> "tar.gz"]- }+ pkgs' <- filterM (fmap not . isFetched . packageSource) pkgs+ if null pkgs'+ --TODO: when we add support for remote tarballs then this message+ -- will need to be changed because for remote tarballs we fetch them+ -- at the earlier phase.+ then notice verbosity $ "No packages need to be fetched. "+ ++ "All the requested packages are already local "+ ++ "or cached locally."+ else if dryRun+ then notice verbosity $ unlines $+ "The following packages would be fetched:"+ : map (display . packageId) pkgs'++ else mapM_ (fetchPackage verbosity . packageSource) pkgs'++ where+ dryRun = fromFlag (fetchDryRun fetchFlags)++planPackages :: Verbosity+ -> Compiler+ -> FetchFlags+ -> PackageIndex InstalledPackage+ -> AvailablePackageDb+ -> [PackageSpecifier AvailablePackage]+ -> IO [AvailablePackage]+planPackages verbosity comp fetchFlags+ installed availableDb pkgSpecifiers++ | includeDependencies = do+ notice verbosity "Resolving dependencies..."+ installPlan <- foldProgress logMsg die return $+ resolveDependencies+ buildPlatform (compilerId comp)+ resolverParams++ -- The packages we want to fetch are those packages the 'InstallPlan'+ -- that are in the 'InstallPlan.Configured' state.+ return+ [ pkg+ | (InstallPlan.Configured (InstallPlan.ConfiguredPackage pkg _ _))+ <- InstallPlan.toList installPlan ]++ | otherwise =+ either (die . unlines . map show) return $+ resolveWithoutDependencies resolverParams++ where+ resolverParams =++ -- Reinstall the targets given on the command line so that the dep+ -- resolver will decide that they need fetching, even if they're+ -- already installed. Sicne we want to get the source packages of+ -- things we might have installed (but not have the sources for).+ reinstallTargets++ $ standardInstallPolicy installed availableDb pkgSpecifiers++ includeDependencies = fromFlag (fetchDeps fetchFlags)+ logMsg message rest = debug verbosity message >> rest+++checkTarget :: UserTarget -> IO ()+checkTarget target = case target of+ UserTargetRemoteTarball _uri+ -> die $ "The 'fetch' command does not yet support remote tarballs. "+ ++ "In the meantime you can use the 'unpack' commands."+ _ -> return ()++fetchPackage :: Verbosity -> PackageLocation a -> IO ()+fetchPackage verbosity pkgsrc = case pkgsrc of+ LocalUnpackedPackage _dir -> return ()+ LocalTarballPackage _file -> return ()++ RemoteTarballPackage _uri _ ->+ die $ "The 'fetch' command does not yet support remote tarballs. "+ ++ "In the meantime you can use the 'unpack' commands."++ RepoTarballPackage repo pkgid _ -> do+ _ <- fetchRepoTarball verbosity repo pkgid+ return ()
+ Distribution/Client/FetchUtils.hs view
@@ -0,0 +1,193 @@+-----------------------------------------------------------------------------+-- |+-- Module : Distribution.Client.FetchUtils+-- Copyright : (c) David Himmelstrup 2005+-- Duncan Coutts 2011+-- License : BSD-like+--+-- Maintainer : cabal-devel@gmail.com+-- Stability : provisional+-- Portability : portable+--+-- Functions for fetching packages+-----------------------------------------------------------------------------+module Distribution.Client.FetchUtils (++ -- * fetching packages+ fetchPackage,+ isFetched,+ checkFetched,++ -- ** specifically for repo packages+ fetchRepoTarball,++ -- * fetching other things+ downloadIndex,+ ) where++import Distribution.Client.Types+import Distribution.Client.HttpUtils+ ( downloadURI, isOldHackageURI )++import Distribution.Package+ ( PackageId, packageName, packageVersion )+import Distribution.Simple.Utils+ ( notice, info, setupMessage )+import Distribution.Text+ ( display )+import Distribution.Verbosity+ ( Verbosity )++import Data.Maybe+import System.Directory+ ( doesFileExist, createDirectoryIfMissing, getTemporaryDirectory )+import System.IO+ ( openTempFile, hClose )+import System.FilePath+ ( (</>), (<.>) )+import qualified System.FilePath.Posix as FilePath.Posix+ ( combine, joinPath )+import Network.URI+ ( URI(uriPath) )++-- ------------------------------------------------------------+-- * Actually fetch things+-- ------------------------------------------------------------++-- | Returns @True@ if the package has already been fetched+-- or does not need fetching.+--+isFetched :: PackageLocation (Maybe FilePath) -> IO Bool+isFetched loc = case loc of+ LocalUnpackedPackage _dir -> return True+ LocalTarballPackage _file -> return True+ RemoteTarballPackage _uri local -> return (isJust local)+ RepoTarballPackage repo pkgid _ -> doesFileExist (packageFile repo pkgid)+++checkFetched :: PackageLocation (Maybe FilePath)+ -> IO (Maybe (PackageLocation FilePath))+checkFetched loc = case loc of+ LocalUnpackedPackage dir ->+ return (Just $ LocalUnpackedPackage dir)+ LocalTarballPackage file ->+ return (Just $ LocalTarballPackage file)+ RemoteTarballPackage uri (Just file) ->+ return (Just $ RemoteTarballPackage uri file)+ RepoTarballPackage repo pkgid (Just file) ->+ return (Just $ RepoTarballPackage repo pkgid file)++ RemoteTarballPackage _uri Nothing -> return Nothing+ RepoTarballPackage repo pkgid Nothing -> do+ let file = packageFile repo pkgid+ exists <- doesFileExist file+ if exists+ then return (Just $ RepoTarballPackage repo pkgid file)+ else return Nothing+++-- | Fetch a package if we don't have it already.+--+fetchPackage :: Verbosity+ -> PackageLocation (Maybe FilePath)+ -> IO (PackageLocation FilePath)+fetchPackage verbosity loc = case loc of+ LocalUnpackedPackage dir ->+ return (LocalUnpackedPackage dir)+ LocalTarballPackage file ->+ return (LocalTarballPackage file)+ RemoteTarballPackage uri (Just file) ->+ return (RemoteTarballPackage uri file)+ RepoTarballPackage repo pkgid (Just file) ->+ return (RepoTarballPackage repo pkgid file)++ RemoteTarballPackage uri Nothing -> do+ path <- downloadTarballPackage uri+ return (RemoteTarballPackage uri path)+ RepoTarballPackage repo pkgid Nothing -> do+ local <- fetchRepoTarball verbosity repo pkgid+ return (RepoTarballPackage repo pkgid local)+ where+ downloadTarballPackage uri = do+ notice verbosity ("Downloading " ++ show uri)+ tmpdir <- getTemporaryDirectory+ (path, hnd) <- openTempFile tmpdir "cabal-.tar.gz"+ hClose hnd+ downloadURI verbosity uri path+ return path+++-- | Fetch a repo package if we don't have it already.+--+fetchRepoTarball :: Verbosity -> Repo -> PackageId -> IO FilePath+fetchRepoTarball verbosity repo pkgid = do+ fetched <- doesFileExist (packageFile repo pkgid)+ if fetched+ then do info verbosity $ display pkgid ++ " has already been downloaded."+ return (packageFile repo pkgid)+ else do setupMessage verbosity "Downloading" pkgid+ downloadRepoPackage+ where+ downloadRepoPackage = case repoKind repo of+ Right LocalRepo -> return (packageFile repo pkgid)++ Left remoteRepo -> do+ let uri = packageURI remoteRepo pkgid+ dir = packageDir repo pkgid+ path = packageFile repo pkgid+ createDirectoryIfMissing True dir+ downloadURI verbosity uri path+ return path++-- | Downloads an index file to [config-dir/packages/serv-id].+--+downloadIndex :: Verbosity -> RemoteRepo -> FilePath -> IO FilePath+downloadIndex verbosity repo cacheDir = do+ let uri = (remoteRepoURI repo) {+ uriPath = uriPath (remoteRepoURI repo)+ `FilePath.Posix.combine` "00-index.tar.gz"+ }+ path = cacheDir </> "00-index" <.> "tar.gz"+ createDirectoryIfMissing True cacheDir+ downloadURI verbosity uri path+ return path+++-- ------------------------------------------------------------+-- * Path utilities+-- ------------------------------------------------------------++-- | Generate the full path to the locally cached copy of+-- the tarball for a given @PackageIdentifer@.+--+packageFile :: Repo -> PackageId -> FilePath+packageFile repo pkgid = packageDir repo pkgid+ </> display pkgid+ <.> "tar.gz"++-- | Generate the full path to the directory where the local cached copy of+-- the tarball for a given @PackageIdentifer@ is stored.+--+packageDir :: Repo -> PackageId -> FilePath+packageDir repo pkgid = repoLocalDir repo+ </> display (packageName pkgid)+ </> display (packageVersion pkgid)++-- | Generate the URI of the tarball for a given package.+--+packageURI :: RemoteRepo -> PackageId -> URI+packageURI repo pkgid | isOldHackageURI (remoteRepoURI repo) =+ (remoteRepoURI repo) {+ uriPath = FilePath.Posix.joinPath+ [uriPath (remoteRepoURI repo)+ ,display (packageName pkgid)+ ,display (packageVersion pkgid)+ ,display pkgid <.> "tar.gz"]+ }+packageURI repo pkgid =+ (remoteRepoURI repo) {+ uriPath = FilePath.Posix.joinPath+ [uriPath (remoteRepoURI repo)+ ,"package"+ ,display pkgid <.> "tar.gz"]+ }
+ Distribution/Client/GZipUtils.hs view
@@ -0,0 +1,44 @@+-----------------------------------------------------------------------------+-- |+-- Module : Distribution.Client.GZipUtils+-- Copyright : (c) Dmitry Astapov 2010+-- License : BSD-like+--+-- Maintainer : cabal-devel@gmail.com+-- Stability : provisional+-- Portability : portable+--+-- Provides a convenience functions for working with files that may or may not+-- be zipped.+-----------------------------------------------------------------------------+module Distribution.Client.GZipUtils (+ maybeDecompress,+ ) where++import qualified Data.ByteString.Lazy.Internal as BS (ByteString(..))+import Data.ByteString.Lazy (ByteString)+import Codec.Compression.GZip+import Codec.Compression.Zlib.Internal++-- | Attempts to decompress the `bytes' under the assumption that+-- "data format" error at the very beginning of the stream means+-- that it is already decompressed. Caller should make sanity checks+-- to verify that it is not, in fact, garbage.+--+-- This is to deal with http proxies that lie to us and transparently+-- decompress without removing the content-encoding header. See:+-- <http://hackage.haskell.org/trac/hackage/ticket/686>+--+maybeDecompress :: ByteString -> ByteString+maybeDecompress bytes = foldStream $ decompressWithErrors gzipOrZlibFormat defaultDecompressParams bytes+ where+ -- DataError at the beginning of the stream probably means that stream is not compressed.+ -- Returning it as-is.+ -- TODO: alternatively, we might consider looking for the two magic bytes+ -- at the beginning of the gzip header.+ foldStream (StreamError DataError _) = bytes+ foldStream somethingElse = doFold somethingElse++ doFold StreamEnd = BS.Empty+ doFold (StreamChunk bs stream) = BS.Chunk bs (doFold stream)+ doFold (StreamError _ msg) = error $ "Codec.Compression.Zlib: " ++ msg
Distribution/Client/Haddock.hs view
@@ -52,10 +52,14 @@ createDirectoryIfMissing True destDir - withTempDirectory verbosity destDir "htemp" $ \tempDir -> do+ withTempDirectory verbosity destDir "tmphaddock" $ \tempDir -> do - let flags = ["--gen-contents", "--gen-index", "--odir="++tempDir] - ++ map (\(i,h) -> "--read-interface=" ++ h ++ "," ++ i) paths+ let flags = [ "--gen-contents"+ , "--gen-index"+ , "--odir=" ++ tempDir+ , "--title=Haskell modules on this system" ]+ ++ [ "--read-interface=" ++ html ++ "," ++ interface+ | (interface, html) <- paths ] rawSystemProgram verbosity confHaddock flags renameFile (tempDir </> "index.html") (tempDir </> destFile) installDirectoryContents verbosity tempDir destDir@@ -71,7 +75,7 @@ $ pkgs haddockPackagePaths :: [InstalledPackageInfo]- -> IO ([(FilePath, FilePath)], Maybe [Char])+ -> IO ([(FilePath, FilePath)], Maybe String) haddockPackagePaths pkgs = do interfaces <- sequence [ case interfaceAndHtmlPath pkg of
Distribution/Client/IndexUtils.hs view
@@ -4,7 +4,7 @@ -- Copyright : (c) Duncan Coutts 2008 -- License : BSD-like ----- Maintainer : duncan@haskell.org+-- Maintainer : duncan@community.haskell.org -- Stability : provisional -- Portability : portable --@@ -16,19 +16,14 @@ readPackageIndexFile, parseRepoIndex,-- disambiguatePackageName,- disambiguateDependencies ) where import qualified Distribution.Client.Tar as Tar import Distribution.Client.Types- ( UnresolvedDependency(..), AvailablePackage(..)- , AvailablePackageSource(..), Repo(..), RemoteRepo(..)- , AvailablePackageDb(..), InstalledPackage(..) ) import Distribution.Package- ( PackageId, PackageIdentifier(..), PackageName(..), Package(..)+ ( PackageId, PackageIdentifier(..), PackageName(..)+ , Package(..), packageVersion , Dependency(Dependency), InstalledPackageId(..) ) import Distribution.Client.PackageIndex (PackageIndex) import qualified Distribution.Client.PackageIndex as PackageIndex@@ -49,12 +44,14 @@ import Distribution.Version ( Version(Version), intersectVersionRanges ) import Distribution.Text- ( display, simpleParse )-import Distribution.Verbosity (Verbosity)-import Distribution.Simple.Utils (die, warn, info, intercalate, fromUTF8)+ ( simpleParse )+import Distribution.Verbosity+ ( Verbosity, lessVerbose )+import Distribution.Simple.Utils+ ( warn, info, fromUTF8, equating ) import Data.Maybe (catMaybes, fromMaybe)-import Data.List (isPrefixOf)+import Data.List (isPrefixOf, groupBy) import Data.Monoid (Monoid(..)) import qualified Data.Map as Map import Control.Monad (MonadPlus(mplus), when)@@ -62,7 +59,7 @@ import qualified Data.ByteString.Lazy as BS import qualified Data.ByteString.Lazy.Char8 as BS.Char8 import Data.ByteString.Lazy (ByteString)-import qualified Codec.Compression.GZip as GZip (decompress)+import Distribution.Client.GZipUtils (maybeDecompress) import System.FilePath ((</>), takeExtension, splitDirectories, normalise) import System.FilePath.Posix as FilePath.Posix ( takeFileName )@@ -74,19 +71,25 @@ getInstalledPackages :: Verbosity -> Compiler -> PackageDBStack -> ProgramConfiguration- -> IO (Maybe (PackageIndex InstalledPackage))+ -> IO (PackageIndex InstalledPackage) getInstalledPackages verbosity comp packageDbs conf =- fmap (fmap convert)- (Configure.getInstalledPackages verbosity comp packageDbs conf)+ fmap convert (Configure.getInstalledPackages verbosity'+ comp packageDbs conf) where+ --FIXME: make getInstalledPackages use sensible verbosity in the first place+ verbosity' = lessVerbose verbosity+ convert :: InstalledPackageIndex.PackageIndex -> PackageIndex InstalledPackage- convert index = PackageIndex.fromList $- reverse -- because later ones mask earlier ones, but- -- InstalledPackageIndex.allPackages gives us the most preferred- -- instances first, when packages share a package id, like when- -- the same package is installed in the global & user dbs.+ convert index = PackageIndex.fromList+ -- There can be multiple installed instances of each package version,+ -- like when the same package is installed in the global & user dbs.+ -- InstalledPackageIndex.allPackagesByName gives us the installed+ -- packages with the most preferred instances first, so by picking the+ -- first we should get the user one. This is almost but not quite the+ -- same as what ghc does. [ InstalledPackage ipkg (sourceDeps index ipkg)- | ipkg <- InstalledPackageIndex.allPackages index ]+ | ipkgs <- InstalledPackageIndex.allPackagesByName index+ , (ipkg:_) <- groupBy (equating packageVersion) ipkgs ] -- The InstalledPackageInfo only lists dependencies by the -- InstalledPackageId, which means we do not directly know the corresponding@@ -154,7 +157,7 @@ [ AvailablePackage { packageInfoId = pkgid, packageDescription = pkg,- packageSource = RepoTarballPackage repo+ packageSource = RepoTarballPackage repo pkgid Nothing } | (pkgid, pkg) <- pkgs] @@ -219,7 +222,7 @@ readPackageIndexFile mkPkg indexFile = do pkgs <- either fail return . parseRepoIndex- . GZip.decompress+ . maybeDecompress =<< BS.readFile indexFile evaluate $ PackageIndex.fromList@@ -260,41 +263,3 @@ check _ (Tar.Fail err) = Left err check ok Tar.Done = Right ok check ok (Tar.Next e es) = check (e:ok) es---- | Disambiguate a set of packages using 'disambiguatePackage' and report any--- ambiguities to the user.----disambiguateDependencies :: PackageIndex AvailablePackage- -> [UnresolvedDependency]- -> IO [UnresolvedDependency]-disambiguateDependencies index deps = do- let names = [ (name, disambiguatePackageName index name)- | UnresolvedDependency (Dependency name _) _ <- deps ]- in case [ (name, matches) | (name, Right matches) <- names ] of- [] -> return- [ UnresolvedDependency (Dependency name vrange) flags- | (UnresolvedDependency (Dependency _ vrange) flags,- (_, Left name)) <- zip deps names ]- ambigious -> die $ unlines- [ if null matches- then "There is no package named " ++ display name ++ ". "- ++ "Perhaps you need to run 'cabal update' first?"- else "The package name " ++ display name ++ "is ambigious. "- ++ "It could be: " ++ intercalate ", " (map display matches)- | (name, matches) <- ambigious ]---- | Given an index of known packages and a package name, figure out which one it--- might be referring to. If there is an exact case-sensitive match then that's--- ok. If it matches just one package case-insensitively then that's also ok.--- The only problem is if it matches multiple packages case-insensitively, in--- that case it is ambigious.----disambiguatePackageName :: PackageIndex AvailablePackage- -> PackageName- -> Either PackageName [PackageName]-disambiguatePackageName index (PackageName name) =- case PackageIndex.searchByName index name of- PackageIndex.None -> Right []- PackageIndex.Unambiguous pkgs -> Left (pkgName (packageId (head pkgs)))- PackageIndex.Ambiguous pkgss -> Right [ pkgName (packageId pkg)- | (pkg:_) <- pkgss ]
Distribution/Client/Init/Heuristics.hs view
@@ -66,7 +66,9 @@ scan dir hierarchy = do entries <- getDirectoryContents (projectRoot </> dir) (files, dirs) <- liftM partitionEithers (mapM (tagIsDir dir) entries)- let modules = catMaybes [ guessModuleName hierarchy file | file <- files ]+ let modules = catMaybes [ guessModuleName hierarchy file+ | file <- files+ , isUpper (head file) ] recMods <- mapM (scanRecursive dir hierarchy) dirs return $ concat (modules : recMods) tagIsDir parent entry = do@@ -83,9 +85,11 @@ ext = case takeExtension entry of '.':e -> e; e -> e scanRecursive parent hierarchy entry | isUpper (head entry) = scan (parent </> entry) (entry : hierarchy)- | isLower (head entry) && entry /= "dist" =+ | isLower (head entry) && not (ignoreDir entry) = scanForModulesIn projectRoot $ foldl (</>) srcRoot (entry : hierarchy) | otherwise = return []+ ignoreDir ('.':_) = True+ ignoreDir dir = dir `elem` ["dist", "_darcs"] -- Unfortunately we cannot use the version exported by Distribution.Simple.Program knownSuffixHandlers :: [(String,String)]
Distribution/Client/Install.hs view
@@ -1,10 +1,13 @@+{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.Client.Install--- Copyright : (c) David Himmelstrup 2005+-- Copyright : (c) 2005 David Himmelstrup+-- 2007 Bjorn Bringert+-- 2007-2010 Duncan Coutts -- License : BSD-like ----- Maintainer : lemmih@gmail.com+-- Maintainer : cabal-devel@haskell.org -- Stability : provisional -- Portability : portable --@@ -19,7 +22,6 @@ ( unfoldr, find, nub, sort ) import Data.Maybe ( isJust, fromMaybe )-import qualified Data.Map as Map import Control.Exception as Exception ( handleJust ) #if MIN_VERSION_base(4,0,0)@@ -44,34 +46,23 @@ import System.IO.Error ( isDoesNotExistError, ioeGetFileName ) +import Distribution.Client.Targets import Distribution.Client.Dependency- ( resolveDependenciesWithProgress- , PackageConstraint(..), dependencyConstraints, dependencyTargets- , PackagesPreference(..), PackagesPreferenceDefault(..)- , PackagePreference(..)- , upgradableDependencies- , Progress(..), foldProgress, )-import Distribution.Client.Fetch (fetchPackage)+import Distribution.Client.FetchUtils import qualified Distribution.Client.Haddock as Haddock (regenerateHaddockIndex) -- import qualified Distribution.Client.Info as Info import Distribution.Client.IndexUtils as IndexUtils- ( getAvailablePackages, disambiguateDependencies- , getInstalledPackages )+ ( getAvailablePackages, getInstalledPackages ) import qualified Distribution.Client.InstallPlan as InstallPlan import Distribution.Client.InstallPlan (InstallPlan) import Distribution.Client.Setup- ( ConfigFlags(..), configureCommand, filterConfigureFlags+ ( GlobalFlags(..)+ , ConfigFlags(..), configureCommand, filterConfigureFlags , ConfigExFlags(..), InstallFlags(..) ) import Distribution.Client.Config- ( defaultLogsDir, defaultCabalDir )+ ( defaultCabalDir ) import Distribution.Client.Tar (extractTarGzFile) import Distribution.Client.Types as Available- ( UnresolvedDependency(..), AvailablePackage(..)- , AvailablePackageSource(..), AvailablePackageDb(..)- , Repo(..), ConfiguredPackage(..)- , BuildResult, BuildFailure(..), BuildSuccess(..)- , DocsResult(..), TestsResult(..), RemoteRepo(..)- , InstalledPackage ) import Distribution.Client.BuildReports.Types ( ReportLevel(..) ) import Distribution.Client.SetupWrapper@@ -82,6 +73,7 @@ import qualified Distribution.Client.InstallSymlink as InstallSymlink ( symlinkBinaries ) import qualified Distribution.Client.Win32SelfUpgrade as Win32SelfUpgrade+import qualified Distribution.Client.World as World import Paths_cabal_install (getBinDir) import Distribution.Simple.Compiler@@ -98,25 +90,23 @@ import qualified Distribution.Simple.Setup as Cabal ( installCommand, InstallFlags(..), emptyInstallFlags ) import Distribution.Simple.Utils- ( defaultPackageDesc, rawSystemExit, comparing )+ ( rawSystemExit, comparing ) import Distribution.Simple.InstallDirs as InstallDirs ( PathTemplate, fromPathTemplate, toPathTemplate, substPathTemplate , initialPathTemplateEnv, installDirsTemplateEnv ) import Distribution.Package- ( PackageName, PackageIdentifier, packageName, packageVersion+ ( PackageIdentifier, packageName, packageVersion , Package(..), PackageFixedDeps(..) , Dependency(..), thisPackageVersion ) import qualified Distribution.PackageDescription as PackageDescription import Distribution.PackageDescription ( PackageDescription )-import Distribution.PackageDescription.Parse- ( readPackageDescription ) import Distribution.PackageDescription.Configuration ( finalizePackageDescription ) import Distribution.Version- ( Version, VersionRange, anyVersion, thisVersion )+ ( Version, anyVersion, thisVersion ) import Distribution.Simple.Utils as Utils- ( notice, info, warn, die, intercalate, withTempDirectory )+ ( notice, info, debug, warn, die, intercalate, withTempDirectory ) import Distribution.Client.Utils ( inDir, mergeBy, MergeResult(..) ) import Distribution.System@@ -127,158 +117,286 @@ ( Verbosity, showForCabal, verbose ) import Distribution.Simple.BuildPaths ( exeExtension ) -data InstallMisc = InstallMisc {- rootCmd :: Maybe FilePath,- libVersion :: Maybe Version- }+--TODO:+-- * assign flags to packages individually+-- * complain about flags that do not apply to any package given as target+-- so flags do not apply to dependencies, only listed, can use flag+-- constraints for dependencies+-- * only record applicable flags in world file+-- * allow flag constraints+-- * allow installed constraints+-- * allow flag and installed preferences+-- * change world file to use cabal section syntax+-- * allow persistent configure flags for each package individually --- |Installs the packages needed to satisfy a list of dependencies.+-- ------------------------------------------------------------+-- * Top level user actions+-- ------------------------------------------------------------++-- | Installs the packages needed to satisfy a list of dependencies.+-- install, upgrade :: Verbosity -> PackageDBStack -> [Repo] -> Compiler -> ProgramConfiguration+ -> GlobalFlags -> ConfigFlags -> ConfigExFlags -> InstallFlags- -> [UnresolvedDependency]+ -> [UserTarget] -> IO ()-install verbosity packageDB repos comp conf- configFlags configExFlags installFlags deps =+install verbosity packageDBs repos comp conf+ globalFlags configFlags configExFlags installFlags userTargets0 = do - installWithPlanner planner- verbosity packageDB repos comp conf- configFlags configExFlags installFlags+ installed <- getInstalledPackages verbosity comp packageDBs conf+ availableDb <- getAvailablePackages verbosity repos++ let -- For install, if no target is given it means we use the+ -- current directory as the single target+ userTargets | null userTargets0 = [UserTargetLocalDir "."]+ | otherwise = userTargets0++ pkgSpecifiers <- resolveUserTargets verbosity+ globalFlags (packageIndex availableDb) userTargets++ notice verbosity "Resolving dependencies..."+ installPlan <- foldProgress logMsg die return $+ planPackages+ comp configFlags configExFlags installFlags+ installed availableDb pkgSpecifiers++ printPlanMessages verbosity installed installPlan dryRun++ unless dryRun $ do+ installPlan' <- performInstallations verbosity+ context installed installPlan+ postInstallActions verbosity context userTargets installPlan'+ where- planner :: Planner- planner | null deps = planLocalPackage verbosity- comp configFlags configExFlags- | otherwise = planRepoPackages PreferLatestForSelected- comp configFlags configExFlags installFlags deps+ context :: InstallContext+ context = (packageDBs, repos, comp, conf,+ globalFlags, configFlags, configExFlags, installFlags) -upgrade verbosity packageDB repos comp conf- configFlags configExFlags installFlags deps =+ dryRun = fromFlag (installDryRun installFlags)+ logMsg message rest = debug verbosity message >> rest - installWithPlanner planner- verbosity packageDB repos comp conf- configFlags configExFlags installFlags++upgrade _ _ _ _ _ _ _ _ _ _ = die $+ "Use the 'cabal install' command instead of 'cabal upgrade'.\n"+ ++ "You can install the latest version of a package using 'cabal install'. "+ ++ "The 'cabal upgrade' command has been removed because people found it "+ ++ "confusing and it often led to broken packages.\n"+ ++ "If you want the old upgrade behaviour then use the install command "+ ++ "with the --upgrade-dependencies flag (but check first with --dry-run "+ ++ "to see what would happen). This will try to pick the latest versions "+ ++ "of all dependencies, rather than the usual behaviour of trying to pick "+ ++ "installed versions of all dependencies. If you do use "+ ++ "--upgrade-dependencies, it is recommended that you do not upgrade core "+ ++ "packages (e.g. by using appropriate --constraint= flags)."++type InstallContext = ( PackageDBStack+ , [Repo]+ , Compiler+ , ProgramConfiguration+ , GlobalFlags+ , ConfigFlags+ , ConfigExFlags+ , InstallFlags )++-- ------------------------------------------------------------+-- * Installation planning+-- ------------------------------------------------------------++planPackages :: Compiler+ -> ConfigFlags+ -> ConfigExFlags+ -> InstallFlags+ -> PackageIndex InstalledPackage+ -> AvailablePackageDb+ -> [PackageSpecifier AvailablePackage]+ -> Progress String String InstallPlan+planPackages comp configFlags configExFlags installFlags+ installed availableDb pkgSpecifiers =++ resolveDependencies+ buildPlatform (compilerId comp)+ resolverParams++ >>= if onlyDeps then adjustPlanOnlyDeps else return+ where- planner :: Planner- planner | null deps = planUpgradePackages- comp configFlags configExFlags- | otherwise = planRepoPackages PreferAllLatest- comp configFlags configExFlags installFlags deps+ resolverParams = -type Planner = Maybe (PackageIndex InstalledPackage)- -> AvailablePackageDb- -> IO (Progress String String InstallPlan)+ setPreferenceDefault (if upgradeDeps then PreferAllLatest+ else PreferLatestForSelected) --- |Installs the packages generated by a planner.-installWithPlanner ::- Planner- -> Verbosity- -> PackageDBStack- -> [Repo]- -> Compiler- -> ProgramConfiguration- -> ConfigFlags- -> ConfigExFlags- -> InstallFlags- -> IO ()-installWithPlanner planner verbosity packageDBs repos comp conf- configFlags configExFlags installFlags = do+ . addPreferences+ -- preferences from the config file or command line+ [ PackageVersionPreference name ver+ | Dependency name ver <- configPreferences configExFlags ] - installed <- getInstalledPackages verbosity comp packageDBs conf- available <- getAvailablePackages verbosity repos+ . addConstraints+ -- version constraints from the config file or command line+ [ PackageVersionConstraint name ver+ | Dependency name ver <- configConstraints configFlags ] - progress <- planner installed available+ . addConstraints+ --FIXME: this just applies all flags to all targets which+ -- is silly. We should check if the flags are appropriate+ [ PackageFlagsConstraint (pkgSpecifierTarget pkgSpecifier) flags+ | let flags = configConfigurationsFlags configFlags+ , not (null flags)+ , pkgSpecifier <- pkgSpecifiers ] - notice verbosity "Resolving dependencies..."- maybePlan <- foldProgress (\message rest -> info verbosity message >> rest)- (return . Left) (return . Right) progress- case maybePlan of- Left message -> die message- Right installPlan -> do- let nothingToInstall = null (InstallPlan.ready installPlan)- when nothingToInstall $- notice verbosity $- "No packages to be installed. All the requested packages are "- ++ "already installed.\n If you want to reinstall anyway then use "- ++ "the --reinstall flag."+ . (if reinstall then reinstallTargets else id) - when (dryRun || verbosity >= verbose) $- printDryRun verbosity installed installPlan+ $ standardInstallPolicy installed availableDb pkgSpecifiers - unless dryRun $ do- logsDir <- defaultLogsDir- let platform = InstallPlan.planPlatform installPlan- compid = InstallPlan.planCompiler installPlan- installPlan' <-- executeInstallPlan installPlan $ \cpkg ->- installConfiguredPackage platform compid configFlags- cpkg $ \configFlags' src pkg ->- installAvailablePackage verbosity (packageId pkg) src $ \mpath ->- installUnpackedPackage verbosity (setupScriptOptions installed)- miscOptions configFlags' installFlags- compid pkg mpath (useLogFile logsDir)+ --TODO: this is a general feature and should be moved to D.C.Dependency+ -- Also, the InstallPlan.remove should return info more precise to the+ -- problem, rather than the very general PlanProblem type.+ adjustPlanOnlyDeps :: InstallPlan -> Progress String String InstallPlan+ adjustPlanOnlyDeps =+ either (Fail . explain) Done+ . InstallPlan.remove isTarget+ where+ isTarget pkg = packageName pkg `elem` targetnames+ targetnames = map pkgSpecifierTarget pkgSpecifiers+ + explain :: [InstallPlan.PlanProblem] -> String+ explain problems =+ "Cannot select only the dependencies (as requested by the "+ ++ "'--only-dependencies' flag), "+ ++ (case pkgids of+ [pkgid] -> "the package " ++ display pkgid ++ " is "+ _ -> "the packages "+ ++ intercalate ", " (map display pkgids) ++ " are ")+ ++ "required by a dependency of one of the other targets."+ where+ pkgids =+ nub [ depid+ | InstallPlan.PackageMissingDeps _ depids <- problems+ , depid <- depids+ , packageName depid `elem` targetnames ] - -- build reporting, local and remote- let buildReports = BuildReports.fromInstallPlan installPlan'- BuildReports.storeLocal (installSummaryFile installFlags) buildReports- when (reportingLevel >= AnonymousReports) $- BuildReports.storeAnonymous buildReports- when (reportingLevel == DetailedReports) $- storeDetailedBuildReports verbosity logsDir buildReports- regenerateHaddockIndex verbosity packageDBs comp conf- configFlags installFlags installPlan'- symlinkBinaries verbosity configFlags installFlags installPlan'- printBuildFailures installPlan'+ reinstall = fromFlag (installReinstall installFlags)+ upgradeDeps = fromFlag (installUpgradeDeps installFlags)+ onlyDeps = fromFlag (installOnlyDeps installFlags) +-- ------------------------------------------------------------+-- * Informational messages+-- ------------------------------------------------------------++printPlanMessages :: Verbosity+ -> PackageIndex InstalledPackage+ -> InstallPlan+ -> Bool+ -> IO ()+printPlanMessages verbosity installed installPlan dryRun = do++ when nothingToInstall $+ notice verbosity $+ "No packages to be installed. All the requested packages are "+ ++ "already installed.\n If you want to reinstall anyway then use "+ ++ "the --reinstall flag."++ when (dryRun || verbosity >= verbose) $+ printDryRun verbosity installed installPlan+ where- setupScriptOptions index = SetupScriptOptions {- useCabalVersion = maybe anyVersion thisVersion (libVersion miscOptions),- useCompiler = Just comp,- -- Hack: we typically want to allow the UserPackageDB for finding the- -- Cabal lib when compiling any Setup.hs even if we're doing a global- -- install. However we also allow looking in a specific package db.- usePackageDB = if UserPackageDB `elem` packageDBs- then packageDBs- else let (db@GlobalPackageDB:dbs) = packageDBs- in db : UserPackageDB : dbs,- --TODO: use Ord instance:- -- insert UserPackageDB packageDBs- usePackageIndex = if UserPackageDB `elem` packageDBs- then index- else Nothing,- useProgramConfig = conf,- useDistPref = fromFlagOrDefault- (useDistPref defaultSetupScriptOptions)- (configDistPref configFlags),- useLoggingHandle = Nothing,- useWorkingDir = Nothing- }+ nothingToInstall = null (InstallPlan.ready installPlan)+++printDryRun :: Verbosity+ -> PackageIndex InstalledPackage+ -> InstallPlan+ -> IO ()+printDryRun verbosity installed plan = case unfoldr next plan of+ [] -> return ()+ pkgs+ | verbosity >= Verbosity.verbose -> notice verbosity $ unlines $+ "In order, the following would be installed:"+ : map showPkgAndReason pkgs+ | otherwise -> notice verbosity $ unlines $+ "In order, the following would be installed (use -v for more details):"+ : map (display . packageId) pkgs+ where+ next plan' = case InstallPlan.ready plan' of+ [] -> Nothing+ (pkg:_) -> Just (pkg, InstallPlan.completed pkgid result plan')+ where pkgid = packageId pkg+ result = BuildOk DocsNotTried TestsNotTried+ --FIXME: This is a bit of a hack,+ -- pretending that each package is installed++ showPkgAndReason pkg' = display (packageId pkg') ++ " " +++ case PackageIndex.lookupPackageName installed (packageName pkg') of+ [] -> "(new package)"+ ps -> case find ((==packageId pkg') . packageId) ps of+ Nothing -> "(new version)"+ Just pkg -> "(reinstall)" ++ case changes pkg pkg' of+ [] -> ""+ diff -> " changes: " ++ intercalate ", " diff+ changes pkg pkg' = map change . filter changed+ $ mergeBy (comparing packageName)+ (nub . sort . depends $ pkg)+ (nub . sort . depends $ pkg')+ change (OnlyInLeft pkgid) = display pkgid ++ " removed"+ change (InBoth pkgid pkgid') = display pkgid ++ " -> "+ ++ display (packageVersion pkgid')+ change (OnlyInRight pkgid') = display pkgid' ++ " added"+ changed (InBoth pkgid pkgid') = pkgid /= pkgid'+ changed _ = True++-- ------------------------------------------------------------+-- * Post installation stuff+-- ------------------------------------------------------------++-- | Various stuff we do after successful or unsuccessfully installing a bunch+-- of packages. This includes:+--+-- * build reporting, local and remote+-- * symlinking binaries+-- * updating indexes+-- * updating world file+-- * error reporting+--+postInstallActions :: Verbosity+ -> InstallContext+ -> [UserTarget]+ -> InstallPlan+ -> IO ()+postInstallActions verbosity+ (packageDBs, _, comp, conf, globalFlags, configFlags, _, installFlags)+ targets installPlan = do++ unless oneShot $+ World.insert verbosity worldFile+ --FIXME: does not handle flags+ [ World.WorldPkgInfo dep []+ | UserTargetNamed dep <- targets ]++ let buildReports = BuildReports.fromInstallPlan installPlan+ BuildReports.storeLocal (installSummaryFile installFlags) buildReports+ when (reportingLevel >= AnonymousReports) $+ BuildReports.storeAnonymous buildReports+ when (reportingLevel == DetailedReports) $+ storeDetailedBuildReports verbosity logsDir buildReports++ regenerateHaddockIndex verbosity packageDBs comp conf+ configFlags installFlags installPlan++ symlinkBinaries verbosity configFlags installFlags installPlan++ printBuildFailures installPlan++ where reportingLevel = fromFlag (installBuildReports installFlags)- useLogFile :: FilePath -> Maybe (PackageIdentifier -> FilePath)- useLogFile logsDir = fmap substLogFileName logFileTemplate- where- logFileTemplate :: Maybe PathTemplate- logFileTemplate --TODO: separate policy from mechanism- | reportingLevel == DetailedReports- = Just $ toPathTemplate $ logsDir </> "$pkgid" <.> "log"- | otherwise- = flagToMaybe (installLogFile installFlags)- substLogFileName template pkg = fromPathTemplate- . substPathTemplate env- $ template- where env = initialPathTemplateEnv (packageId pkg) (compilerId comp)- dryRun = fromFlag (installDryRun installFlags)- miscOptions = InstallMisc {- rootCmd = if fromFlag (configUserInstall configFlags)- then Nothing -- ignore --root-cmd if --user.- else flagToMaybe (installRootCmd installFlags),- libVersion = flagToMaybe (configCabalVersion configExFlags)- }+ logsDir = fromFlag (globalLogsDir globalFlags)+ oneShot = fromFlag (installOneShot installFlags)+ worldFile = fromFlag $ globalWorldFile globalFlags storeDetailedBuildReports :: Verbosity -> FilePath -> [(BuildReports.BuildReport, Repo)] -> IO ()@@ -316,6 +434,7 @@ | isDoesNotExistError ioe = Just ioe missingFile _ = Nothing + regenerateHaddockIndex :: Verbosity -> [PackageDB] -> Compiler@@ -340,9 +459,7 @@ --TODO: might be nice if the install plan gave us the new InstalledPackageInfo installed <- getInstalledPackages verbosity comp packageDBs conf- case installed of- Nothing -> return () -- warning ?- Just index -> Haddock.regenerateHaddockIndex verbosity index conf indexFile+ Haddock.regenerateHaddockIndex verbosity installed conf indexFile | otherwise = return () where@@ -377,148 +494,6 @@ defaultDirs (configInstallDirs configFlags) --- | Make an 'InstallPlan' for the unpacked package in the current directory,--- and all its dependencies.----planLocalPackage :: Verbosity -> Compiler- -> ConfigFlags -> ConfigExFlags -> Planner-planLocalPackage verbosity comp configFlags configExFlags installed- (AvailablePackageDb available availablePrefs) = do- pkg <- readPackageDescription verbosity =<< defaultPackageDesc verbosity- let -- The trick is, we add the local package to the available index and- -- remove it from the installed index. Then we ask to resolve a- -- dependency on exactly that package. So the resolver ends up having- -- to pick the local package.- available' = PackageIndex.insert localPkg available- installed' = PackageIndex.deletePackageId (packageId localPkg) `fmap` installed- localPkg = AvailablePackage {- packageInfoId = packageId pkg,- Available.packageDescription = pkg,- packageSource = LocalUnpackedPackage- }- targets = [packageName pkg]- constraints = [PackageVersionConstraint (packageName pkg)- (thisVersion (packageVersion pkg))- ,PackageFlagsConstraint (packageName pkg)- (configConfigurationsFlags configFlags)]- ++ [ PackageVersionConstraint name ver- | Dependency name ver <- configConstraints configFlags ]- preferences = mergePackagePrefs PreferLatestForSelected- availablePrefs configExFlags-- return $ resolveDependenciesWithProgress buildPlatform (compilerId comp)- installed' available' preferences constraints targets---- | Make an 'InstallPlan' for the given dependencies.----planRepoPackages :: PackagesPreferenceDefault -> Compiler- -> ConfigFlags -> ConfigExFlags -> InstallFlags- -> [UnresolvedDependency] -> Planner-planRepoPackages defaultPref comp configFlags configExFlags installFlags- deps installed (AvailablePackageDb available availablePrefs) = do-- deps' <- IndexUtils.disambiguateDependencies available deps- let installed'- | fromFlag (installReinstall installFlags)- = fmap (hideGivenDeps deps') installed- | otherwise = installed- targets = dependencyTargets deps'- constraints = dependencyConstraints deps'- ++ [ PackageVersionConstraint name ver- | Dependency name ver <- configConstraints configFlags ]- preferences = mergePackagePrefs defaultPref availablePrefs configExFlags- return $ resolveDependenciesWithProgress buildPlatform (compilerId comp)- installed' available preferences constraints targets- where- hideGivenDeps pkgs index =- foldr PackageIndex.deletePackageName index- [ name | UnresolvedDependency (Dependency name _) _ <- pkgs ]--planUpgradePackages :: Compiler -> ConfigFlags -> ConfigExFlags -> Planner-planUpgradePackages _comp _configFlags _configExFlags (Just installed)- (AvailablePackageDb available _availablePrefs) = die $- "the 'upgrade' command (when used without any package arguments) has "- ++ "been disabled in this release. It has been disabled because it has "- ++ "frequently led people to accidentally break their set of installed "- ++ "packages. It will be re-enabled when it is safer to use.\n"- ++ "Below is the list of packages that it would have tried to upgrade. You "- ++ "can use the 'install' command to install the ones you want. Note that "- ++ "it is generally not recommended to upgrade core packages.\n"- ++ unlines [ display pkgid | Dependency pkgid _ <- deps ]----TODO: improve upgrade so we can re-enable it--- return $--- resolveDependenciesWithProgress buildPlatform (compilerId comp)--- (Just installed) available preferences constraints targets- where- deps = upgradableDependencies installed available--- preferences = mergePackagePrefs PreferAllLatest availablePrefs configExFlags--- constraints = [ PackageVersionConstraint name ver--- | Dependency name ver <- deps ]--- ++ [ PackageVersionConstraint name ver--- | Dependency name ver <- configConstraints configFlags ]--- targets = [ name | Dependency name _ <- deps ]--planUpgradePackages comp _ _ _ _ =- die $ display (compilerId comp)- ++ " does not track installed packages so cabal cannot figure out what"- ++ " packages need to be upgraded."--mergePackagePrefs :: PackagesPreferenceDefault- -> Map.Map PackageName VersionRange- -> ConfigExFlags- -> PackagesPreference-mergePackagePrefs defaultPref availablePrefs configExFlags =- PackagesPreference defaultPref $- -- The preferences that come from the hackage index- [ PackageVersionPreference name ver- | (name, ver) <- Map.toList availablePrefs ]- -- additional preferences from the config file or command line- ++ [ PackageVersionPreference name ver- | Dependency name ver <- configPreferences configExFlags ]--printDryRun :: Verbosity -> Maybe (PackageIndex InstalledPackage)- -> InstallPlan -> IO ()-printDryRun verbosity minstalled plan = case unfoldr next plan of- [] -> return ()- pkgs- | verbosity >= Verbosity.verbose -> notice verbosity $ unlines $- "In order, the following would be installed:"- : map showPkgAndReason pkgs- | otherwise -> notice verbosity $ unlines $- "In order, the following would be installed (use -v for more details):"- : map (display . packageId) pkgs- where- next plan' = case InstallPlan.ready plan' of- [] -> Nothing- (pkg:_) -> Just (pkg, InstallPlan.completed pkgid result plan')- where pkgid = packageId pkg- result = BuildOk DocsNotTried TestsNotTried- --FIXME: This is a bit of a hack,- -- pretending that each package is installed-- showPkgAndReason pkg' = display (packageId pkg') ++ " " ++- case minstalled of- Nothing -> ""- Just installed ->- case PackageIndex.lookupPackageName installed (packageName pkg') of- [] -> "(new package)"- ps -> case find ((==packageId pkg') . packageId) ps of- Nothing -> "(new version)"- Just pkg -> "(reinstall)" ++ case changes pkg pkg' of- [] -> ""- diff -> " changes: " ++ intercalate ", " diff- changes pkg pkg' = map change . filter changed- $ mergeBy (comparing packageName)- (nub . sort . depends $ pkg)- (nub . sort . depends $ pkg')- change (OnlyInLeft pkgid) = display pkgid ++ " removed"- change (InBoth pkgid pkgid') = display pkgid ++ " -> "- ++ display (packageVersion pkgid')- change (OnlyInRight pkgid') = display pkgid' ++ " added"- changed (InBoth pkgid pkgid') = pkgid /= pkgid'- changed _ = True- symlinkBinaries :: Verbosity -> ConfigFlags -> InstallFlags@@ -545,6 +520,7 @@ where bindir = fromFlag (installSymlinkBinDir installFlags) + printBuildFailures :: InstallPlan -> IO () printBuildFailures plan = case [ (pkg, reason)@@ -569,6 +545,84 @@ InstallFailed e -> " failed during the final install step." ++ " The exception was:\n " ++ show e ++-- ------------------------------------------------------------+-- * Actually do the installations+-- ------------------------------------------------------------++data InstallMisc = InstallMisc {+ rootCmd :: Maybe FilePath,+ libVersion :: Maybe Version+ }++performInstallations :: Verbosity+ -> InstallContext+ -> PackageIndex InstalledPackage+ -> InstallPlan+ -> IO InstallPlan+performInstallations verbosity+ (packageDBs, _, comp, conf,+ globalFlags, configFlags, configExFlags, installFlags)+ installed installPlan = do++ executeInstallPlan installPlan $ \cpkg ->+ installConfiguredPackage platform compid configFlags+ cpkg $ \configFlags' src pkg ->+ fetchAvailablePackage verbosity src $ \src' ->+ installLocalPackage verbosity (packageId pkg) src' $ \mpath ->+ installUnpackedPackage verbosity (setupScriptOptions installed)+ miscOptions configFlags' installFlags+ compid pkg mpath useLogFile++ where+ platform = InstallPlan.planPlatform installPlan+ compid = InstallPlan.planCompiler installPlan++ setupScriptOptions index = SetupScriptOptions {+ useCabalVersion = maybe anyVersion thisVersion (libVersion miscOptions),+ useCompiler = Just comp,+ -- Hack: we typically want to allow the UserPackageDB for finding the+ -- Cabal lib when compiling any Setup.hs even if we're doing a global+ -- install. However we also allow looking in a specific package db.+ usePackageDB = if UserPackageDB `elem` packageDBs+ then packageDBs+ else let (db@GlobalPackageDB:dbs) = packageDBs+ in db : UserPackageDB : dbs,+ --TODO: use Ord instance:+ -- insert UserPackageDB packageDBs+ usePackageIndex = if UserPackageDB `elem` packageDBs+ then Just index+ else Nothing,+ useProgramConfig = conf,+ useDistPref = fromFlagOrDefault+ (useDistPref defaultSetupScriptOptions)+ (configDistPref configFlags),+ useLoggingHandle = Nothing,+ useWorkingDir = Nothing+ }+ reportingLevel = fromFlag (installBuildReports installFlags)+ logsDir = fromFlag (globalLogsDir globalFlags)+ useLogFile :: Maybe (PackageIdentifier -> FilePath)+ useLogFile = fmap substLogFileName logFileTemplate+ where+ logFileTemplate :: Maybe PathTemplate+ logFileTemplate --TODO: separate policy from mechanism+ | reportingLevel == DetailedReports+ = Just $ toPathTemplate $ logsDir </> "$pkgid" <.> "log"+ | otherwise+ = flagToMaybe (installLogFile installFlags)+ substLogFileName template pkg = fromPathTemplate+ . substPathTemplate env+ $ template+ where env = initialPathTemplateEnv (packageId pkg) (compilerId comp)+ miscOptions = InstallMisc {+ rootCmd = if fromFlag (configUserInstall configFlags)+ then Nothing -- ignore --root-cmd if --user.+ else flagToMaybe (installRootCmd installFlags),+ libVersion = flagToMaybe (configCabalVersion configExFlags)+ }++ executeInstallPlan :: Monad m => InstallPlan -> (ConfiguredPackage -> m BuildResult)@@ -591,6 +645,7 @@ -- now cannot build, we mark as failing due to 'DependentFailed' -- which kind of means it was not their fault. + -- | Call an installer for an 'AvailablePackage' but override the configure -- flags with the ones given by the 'ConfiguredPackage'. In particular the -- 'ConfiguredPackage' specifies an exact 'FlagAssignment' and exactly@@ -599,7 +654,7 @@ -- installConfiguredPackage :: Platform -> CompilerId -> ConfigFlags -> ConfiguredPackage- -> (ConfigFlags -> AvailablePackageSource+ -> (ConfigFlags -> PackageLocation (Maybe FilePath) -> PackageDescription -> a) -> a installConfiguredPackage platform comp configFlags@@ -615,31 +670,59 @@ Left _ -> error "finalizePackageDescription ConfiguredPackage failed" Right (desc, _) -> desc -installAvailablePackage- :: Verbosity -> PackageIdentifier -> AvailablePackageSource+fetchAvailablePackage+ :: Verbosity+ -> PackageLocation (Maybe FilePath)+ -> (PackageLocation FilePath -> IO BuildResult)+ -> IO BuildResult+fetchAvailablePackage verbosity src installPkg = do+ fetched <- checkFetched src+ case fetched of+ Just src' -> installPkg src'+ Nothing -> onFailure DownloadFailed $+ fetchPackage verbosity src >>= installPkg+++installLocalPackage+ :: Verbosity -> PackageIdentifier -> PackageLocation FilePath -> (Maybe FilePath -> IO BuildResult) -> IO BuildResult-installAvailablePackage _ _ LocalUnpackedPackage installPkg =- installPkg Nothing+installLocalPackage verbosity pkgid location installPkg = case location of -installAvailablePackage verbosity pkgid (RepoTarballPackage repo) installPkg =- onFailure DownloadFailed $ do- pkgPath <- fetchPackage verbosity repo pkgid+ LocalUnpackedPackage dir ->+ installPkg (Just dir)++ LocalTarballPackage tarballPath ->+ installLocalTarballPackage verbosity pkgid tarballPath installPkg++ RemoteTarballPackage _ tarballPath ->+ installLocalTarballPackage verbosity pkgid tarballPath installPkg++ RepoTarballPackage _ _ tarballPath ->+ installLocalTarballPackage verbosity pkgid tarballPath installPkg+++installLocalTarballPackage+ :: Verbosity -> PackageIdentifier -> FilePath+ -> (Maybe FilePath -> IO BuildResult)+ -> IO BuildResult+installLocalTarballPackage verbosity pkgid tarballPath installPkg = do+ tmp <- getTemporaryDirectory+ withTempDirectory verbosity tmp (display pkgid) $ \tmpDirPath -> onFailure UnpackFailed $ do- tmp <- getTemporaryDirectory- withTempDirectory verbosity tmp (display pkgid) $ \tmpDirPath -> do- info verbosity $ "Extracting " ++ pkgPath- ++ " to " ++ tmpDirPath ++ "..."- let relUnpackedPath = display pkgid- absUnpackedPath = tmpDirPath </> relUnpackedPath- descFilePath = absUnpackedPath- </> display (packageName pkgid) <.> "cabal"- extractTarGzFile tmpDirPath relUnpackedPath pkgPath- exists <- doesFileExist descFilePath- when (not exists) $- die $ "Package .cabal file not found: " ++ show descFilePath- installPkg (Just absUnpackedPath)+ info verbosity $ "Extracting " ++ tarballPath+ ++ " to " ++ tmpDirPath ++ "..."+ let relUnpackedPath = display pkgid+ absUnpackedPath = tmpDirPath </> relUnpackedPath+ descFilePath = absUnpackedPath+ </> display (packageName pkgid) <.> "cabal"+ extractTarGzFile tmpDirPath relUnpackedPath tarballPath+ exists <- doesFileExist descFilePath+ when (not exists) $+ die $ "Package .cabal file not found: " ++ show descFilePath+ installPkg (Just absUnpackedPath) + installUnpackedPackage :: Verbosity -> SetupScriptOptions -> InstallMisc@@ -684,7 +767,7 @@ where configureFlags = filterConfigureFlags configFlags { configVerbosity = toFlag verbosity'- } + } buildCommand' = buildCommand defaultProgramConfiguration buildFlags _ = emptyBuildFlags { buildDistPref = configDistPref configFlags,@@ -729,6 +812,7 @@ ,"--verbose=" ++ showForCabal verbosity] else die $ "Unable to find cabal executable at: " ++ self + -- helper onFailure :: (SomeException -> BuildFailure) -> IO BuildResult -> IO BuildResult onFailure result action =@@ -745,6 +829,11 @@ `catchIO` (return . Left . result . IOException) `catchExit` (return . Left . result . ExitException) #endif+++-- ------------------------------------------------------------+-- * Wierd windows hacks+-- ------------------------------------------------------------ withWin32SelfUpgrade :: Verbosity -> ConfigFlags
Distribution/Client/InstallPlan.hs view
@@ -4,7 +4,7 @@ -- Copyright : (c) Duncan Coutts 2008 -- License : BSD-like ----- Maintainer : duncan@haskell.org+-- Maintainer : duncan@community.haskell.org -- Stability : provisional -- Portability : portable --@@ -22,6 +22,7 @@ ready, completed, failed,+ remove, -- ** Query functions planPlatform,@@ -180,6 +181,21 @@ toList :: InstallPlan -> [PlanPackage] toList = PackageIndex.allPackages . planIndex++-- | Remove packages from the install plan. This will result in an+-- error if there are remaining packages that depend on any matching+-- package. This is primarily useful for obtaining an install plan for+-- the dependencies of a package or set of packages without actually+-- installing the package itself, as when doing development.+--+remove :: (PlanPackage -> Bool)+ -> InstallPlan+ -> Either [PlanProblem] InstallPlan+remove shouldRemove plan =+ new (planPlatform plan) (planCompiler plan) newIndex+ where+ newIndex = PackageIndex.fromList $+ filter (not . shouldRemove) (toList plan) -- | The packages that are ready to be installed. That is they are in the -- configured state and have all their dependencies installed already.
Distribution/Client/List.hs view
@@ -2,7 +2,7 @@ -- | -- Module : Distribution.Client.List -- Copyright : (c) David Himmelstrup 2005--- Duncan Coutts 2008-2009+-- Duncan Coutts 2008-2011 -- License : BSD-like -- -- Maintainer : cabal-devel@haskell.org@@ -14,8 +14,8 @@ ) where import Distribution.Package- ( PackageName(..), packageName, packageVersion- , Dependency(..), thisPackageVersion, depends )+ ( PackageName(..), Package(..), packageName, packageVersion+ , Dependency(..), thisPackageVersion, depends, simplifyDependency ) import Distribution.ModuleName (ModuleName) import Distribution.License (License) import qualified Distribution.InstalledPackageInfo as Installed@@ -28,31 +28,39 @@ import Distribution.Simple.Compiler ( Compiler, PackageDBStack ) import Distribution.Simple.Program (ProgramConfiguration)-import Distribution.Simple.Utils (equating, comparing, notice)+import Distribution.Simple.Utils+ ( equating, comparing, die, notice ) import Distribution.Simple.Setup (fromFlag) import qualified Distribution.Client.PackageIndex as PackageIndex-import Distribution.Version (Version)+import Distribution.Version+ ( Version(..), VersionRange, withinRange, anyVersion+ , intersectVersionRanges, simplifyVersionRange ) import Distribution.Verbosity (Verbosity) import Distribution.Text ( Text(disp), display ) import Distribution.Client.Types ( AvailablePackage(..), Repo, AvailablePackageDb(..)- , UnresolvedDependency(..), InstalledPackage(..) )+ , InstalledPackage(..) )+import Distribution.Client.Dependency.Types+ ( PackageConstraint(..) )+import Distribution.Client.Targets+ ( UserTarget, resolveUserTargets, PackageSpecifier(..) ) import Distribution.Client.Setup- ( ListFlags(..), InfoFlags(..) )+ ( GlobalFlags(..), ListFlags(..), InfoFlags(..) ) import Distribution.Client.Utils ( mergeBy, MergeResult(..) ) import Distribution.Client.IndexUtils as IndexUtils- ( getAvailablePackages, disambiguateDependencies- , getInstalledPackages )-import Distribution.Client.Fetch+ ( getAvailablePackages, getInstalledPackages )+import Distribution.Client.FetchUtils ( isFetched ) import Data.List- ( sortBy, groupBy, sort, nub, intersperse, maximumBy )+ ( sortBy, groupBy, sort, nub, intersperse, maximumBy, partition ) import Data.Maybe- ( listToMaybe, fromJust, fromMaybe, isJust, isNothing )+ ( listToMaybe, fromJust, fromMaybe, isJust )+import qualified Data.Map as Map+import Data.Tree as Tree import Control.Monad ( MonadPlus(mplus), join ) import Control.Exception@@ -72,66 +80,141 @@ -> [String] -> IO () list verbosity packageDBs repos comp conf listFlags pats = do- Just installed <- getInstalledPackages verbosity comp packageDBs conf- AvailablePackageDb available _ <- getAvailablePackages verbosity repos- let pkgs | null pats = (PackageIndex.allPackages installed- ,PackageIndex.allPackages available)- | otherwise =- (concatMap (PackageIndex.searchByNameSubstring installed) pats- ,concatMap (PackageIndex.searchByNameSubstring available) pats)- matches = installedFilter- . map (uncurry mergePackageInfo)- $ uncurry mergePackages pkgs + installed <- getInstalledPackages verbosity comp packageDBs conf+ availableDb <- getAvailablePackages verbosity repos+ let available = packageIndex availableDb+ prefs name = fromMaybe anyVersion+ (Map.lookup name (packagePreferences availableDb))++ pkgsInfo :: [(PackageName, [InstalledPackage], [AvailablePackage])]+ pkgsInfo+ -- gather info for all packages+ | null pats = mergePackages (PackageIndex.allPackages installed)+ (PackageIndex.allPackages available)++ -- gather info for packages matching search term+ | otherwise = mergePackages (matchingPackages installed)+ (matchingPackages available)++ matches :: [PackageDisplayInfo]+ matches = [ mergePackageInfo pref+ installedPkgs availablePkgs selectedPkg False+ | (pkgname, installedPkgs, availablePkgs) <- pkgsInfo+ , not onlyInstalled || not (null installedPkgs)+ , let pref = prefs pkgname+ selectedPkg = latestWithPref pref availablePkgs ]+ if simpleOutput then putStr $ unlines- [ display (pkgname pkg) ++ " " ++ display version+ [ display (pkgName pkg) ++ " " ++ display version | pkg <- matches , version <- if onlyInstalled then installedVersions pkg else nub . sort $ installedVersions pkg ++ availableVersions pkg ]+ -- Note: this only works because for 'list', one cannot currently+ -- specify any version constraints, so listing all installed+ -- and available ones works. else if null matches then notice verbosity "No matches found." else putStr $ unlines (map showPackageSummaryInfo matches) where- installedFilter- | onlyInstalled = filter (not . null . installedVersions)- | otherwise = id onlyInstalled = fromFlag (listInstalled listFlags) simpleOutput = fromFlag (listSimpleOutput listFlags) + matchingPackages index =+ [ pkg+ | pat <- pats+ , (_, pkgs) <- PackageIndex.searchByNameSubstring index pat+ , pkg <- pkgs ]+ info :: Verbosity -> PackageDBStack -> [Repo] -> Compiler -> ProgramConfiguration+ -> GlobalFlags -> InfoFlags- -> [UnresolvedDependency] --FIXME: just package names? or actually use the constraint+ -> [UserTarget] -> IO ()-info verbosity packageDBs repos comp conf _listFlags deps = do- AvailablePackageDb available _ <- getAvailablePackages verbosity repos- deps' <- IndexUtils.disambiguateDependencies available deps- Just installed <- getInstalledPackages verbosity comp packageDBs conf- let deps'' = [ name | UnresolvedDependency (Dependency name _) _ <- deps' ]- let pkgs = (concatMap (PackageIndex.lookupPackageName installed) deps''- ,concatMap (PackageIndex.lookupPackageName available) deps'')- pkgsinfo = map (uncurry mergePackageInfo)- $ uncurry mergePackages pkgs+info verbosity packageDBs repos comp conf+ globalFlags _listFlags userTargets = do - pkgsinfo' <- mapM updateFileSystemPackageDetails pkgsinfo- putStr $ unlines (map showPackageDetailedInfo pkgsinfo')+ installed <- getInstalledPackages verbosity comp packageDBs conf+ availableDb <- getAvailablePackages verbosity repos+ let available = packageIndex availableDb+ prefs name = fromMaybe anyVersion+ (Map.lookup name (packagePreferences availableDb)) + -- Users may specify names of packages that are only installed, not+ -- just available source packages, so we must resolve targets using+ -- the combination of installed and available packages.+ let available' = PackageIndex.fromList+ $ map packageId (PackageIndex.allPackages installed)+ ++ map packageId (PackageIndex.allPackages available)+ pkgSpecifiers <- resolveUserTargets verbosity+ globalFlags available' userTargets++ pkgsinfo <- sequence+ [ do pkginfo <- either die return $+ gatherPkgInfo prefs+ installed available pkgSpecifier+ updateFileSystemPackageDetails pkginfo+ | pkgSpecifier <- pkgSpecifiers ]++ putStr $ unlines (map showPackageDetailedInfo pkgsinfo)++ where+ gatherPkgInfo prefs installed available (NamedPackage name constraints)+ | null (selectedInstalledPkgs) && null (selectedAvailablePkgs)+ = Left $ "There is no available version of " ++ display name+ ++ " that satisfies "+ ++ display (simplifyVersionRange verConstraint)++ | otherwise+ = Right $ mergePackageInfo pref installedPkgs+ availablePkgs selectedAvailablePkg+ showPkgVersion+ where+ pref = prefs name+ installedPkgs = PackageIndex.lookupPackageName installed name+ availablePkgs = PackageIndex.lookupPackageName available name++ selectedInstalledPkgs = PackageIndex.lookupDependency installed+ (Dependency name verConstraint)+ selectedAvailablePkgs = PackageIndex.lookupDependency available+ (Dependency name verConstraint)+ selectedAvailablePkg = latestWithPref pref selectedAvailablePkgs++ -- display a specific package version if the user+ -- supplied a non-trivial version constraint+ showPkgVersion = not (null verConstraints)+ verConstraint = foldr intersectVersionRanges anyVersion verConstraints+ verConstraints = [ vr | PackageVersionConstraint _ vr <- constraints ]++ gatherPkgInfo prefs installed available (SpecificSourcePackage pkg) =+ Right $ mergePackageInfo pref installedPkgs availablePkgs+ selectedPkg True+ where+ name = packageName pkg+ pref = prefs name+ installedPkgs = PackageIndex.lookupPackageName installed name+ availablePkgs = PackageIndex.lookupPackageName available name+ selectedPkg = Just pkg++ -- | The info that we can display for each package. It is information per -- package name and covers all installed and avilable versions. -- data PackageDisplayInfo = PackageDisplayInfo {- pkgname :: PackageName,- allInstalled :: [InstalledPackage],- allAvailable :: [AvailablePackage],- latestInstalled :: Maybe InstalledPackage,- latestAvailable :: Maybe AvailablePackage,+ pkgName :: PackageName,+ selectedVersion :: Maybe Version,+ selectedAvailable :: Maybe AvailablePackage,+ installedVersions :: [Version],+ availableVersions :: [Version],+ preferredVersions :: VersionRange, homepage :: String, bugReports :: String, sourceRepo :: String,@@ -139,7 +222,6 @@ description :: String, category :: String, license :: License,--- copyright :: String, --TODO: is this useful? author :: String, maintainer :: String, dependencies :: [Dependency],@@ -152,28 +234,23 @@ haveTarball :: Bool } -installedVersions :: PackageDisplayInfo -> [Version]-installedVersions = map packageVersion . allInstalled--availableVersions :: PackageDisplayInfo -> [Version]-availableVersions = map packageVersion . allAvailable- showPackageSummaryInfo :: PackageDisplayInfo -> String showPackageSummaryInfo pkginfo = renderStyle (style {lineLength = 80, ribbonsPerLine = 1}) $- char '*' <+> disp (pkgname pkginfo)+ char '*' <+> disp (pkgName pkginfo) $+$ (nest 4 $ vcat [ maybeShow (synopsis pkginfo) "Synopsis:" reflowParagraphs- , text "Latest version available:" <+>- case latestAvailable pkginfo of- Nothing -> text "[ Not available from server ]"- Just pkg -> disp (packageVersion pkg)- , text "Latest version installed:" <+>- case latestInstalled pkginfo of- Nothing | hasLib pkginfo -> text "[ Not installed ]"- | otherwise -> text "[ Unknown ]"+ , text "Default available version:" <+>+ case selectedAvailable pkginfo of+ Nothing -> text "[ Not available from any configured repository ]" Just pkg -> disp (packageVersion pkg)+ , text "Installed versions:" <+>+ case installedVersions pkginfo of+ [] | hasLib pkginfo -> text "[ Not installed ]"+ | otherwise -> text "[ Unknown ]"+ versions -> dispTopVersions 4+ (preferredVersions pkginfo) versions , maybeShow (homepage pkginfo) "Homepage:" text , text "License: " <+> text (display (license pkginfo)) ])@@ -185,22 +262,23 @@ showPackageDetailedInfo :: PackageDisplayInfo -> String showPackageDetailedInfo pkginfo = renderStyle (style {lineLength = 80, ribbonsPerLine = 1}) $- char '*' <+> disp (pkgname pkginfo)- <+> text (replicate (16 - length (display (pkgname pkginfo))) ' ')+ char '*' <+> disp (pkgName pkginfo)+ <> maybe empty (\v -> char '-' <> disp v) (selectedVersion pkginfo)+ <+> text (replicate (16 - length (display (pkgName pkginfo))) ' ') <> parens pkgkind $+$ (nest 4 $ vcat [- entry "Synopsis" synopsis alwaysShow reflowParagraphs- , entry "Latest version available" latestAvailable- (altText isNothing "[ Not available from server ]")- (disp . packageVersion . fromJust)- , entry "Latest version installed" latestInstalled- (altText isNothing (if hasLib pkginfo then "[ Not installed ]"- else "[ Unknown ]"))- (disp . packageVersion . fromJust)+ entry "Synopsis" synopsis hideIfNull reflowParagraphs+ , entry "Versions available" availableVersions+ (altText null "[ Not available from server ]")+ (dispTopVersions 9 (preferredVersions pkginfo))+ , entry "Versions installed" installedVersions+ (altText null (if hasLib pkginfo then "[ Not installed ]"+ else "[ Unknown ]"))+ (dispTopVersions 4 (preferredVersions pkginfo)) , entry "Homepage" homepage orNotSpecified text , entry "Bug reports" bugReports orNotSpecified text- , entry "Description" description alwaysShow reflowParagraphs+ , entry "Description" description hideIfNull reflowParagraphs , entry "Category" category hideIfNull text , entry "License" license alwaysShow disp , entry "Author" author hideIfNull reflowLines@@ -252,6 +330,7 @@ | hasExe pkginfo = text "program" | otherwise = empty + reflowParagraphs :: String -> Doc reflowParagraphs = vcat@@ -271,18 +350,24 @@ -- the input package info records are all supposed to refer to the same -- package name. ---mergePackageInfo :: [InstalledPackage]+mergePackageInfo :: VersionRange+ -> [InstalledPackage] -> [AvailablePackage]+ -> Maybe AvailablePackage+ -> Bool -> PackageDisplayInfo-mergePackageInfo installedPkgs availablePkgs =+mergePackageInfo versionPref installedPkgs availablePkgs selectedPkg showVer = assert (length installedPkgs + length availablePkgs > 0) $ PackageDisplayInfo {- pkgname = combine packageName available- packageName installed,- allInstalled = installedPkgs,- allAvailable = availablePkgs,- latestInstalled = latest installedPkgs,- latestAvailable = latest availablePkgs,+ pkgName = combine packageName available+ packageName installed,+ selectedVersion = if showVer then fmap packageVersion selectedPkg+ else Nothing,+ selectedAvailable = availableSelected,+ installedVersions = map packageVersion installedPkgs,+ availableVersions = map packageVersion availablePkgs,+ preferredVersions = versionPref,+ license = combine Available.license available Installed.license installed, maintainer = combine Available.maintainer available@@ -297,8 +382,8 @@ . sortBy (comparing Available.repoKind) . Available.sourceRepos) $ available,- synopsis = combine Available.synopsis available- Installed.description installed,+ --TODO: installed package info is missing synopsis+ synopsis = maybe "" Available.synopsis available, description = combine Available.description available Installed.description installed, category = combine Available.category available@@ -313,7 +398,8 @@ modules = combine Installed.exposedModules installed (maybe [] Available.exposedModules . Available.library) available,- dependencies = combine Available.buildDepends available+ dependencies = map simplifyDependency+ $ combine Available.buildDepends available (map thisPackageVersion . depends) installed', haddockHtml = fromMaybe "" . join . fmap (listToMaybe . Installed.haddockHTMLs)@@ -322,47 +408,121 @@ } where combine f x g y = fromJust (fmap f x `mplus` fmap g y)- installed' = latest installedPkgs+ installed' = latestWithPref versionPref installedPkgs installed = fmap (\(InstalledPackage p _) -> p) installed'- availableGeneric = fmap packageDescription (latest availablePkgs)++ availableSelected+ | isJust selectedPkg = selectedPkg+ | otherwise = latestWithPref versionPref availablePkgs+ availableGeneric = fmap packageDescription availableSelected available = fmap flattenPackageDescription availableGeneric- latest [] = Nothing- latest pkgs = Just (maximumBy (comparing packageVersion) pkgs) uncons :: b -> (a -> b) -> [a] -> b uncons z _ [] = z uncons _ f (x:_) = f x + -- | Not all the info is pure. We have to check if the docs really are -- installed, because the registered package info lies. Similarly we have to -- check if the tarball has indeed been fetched. -- updateFileSystemPackageDetails :: PackageDisplayInfo -> IO PackageDisplayInfo updateFileSystemPackageDetails pkginfo = do- fetched <- maybe (return False) isFetched (latestAvailable pkginfo)+ fetched <- maybe (return False) (isFetched . packageSource)+ (selectedAvailable pkginfo) docsExist <- doesDirectoryExist (haddockHtml pkginfo) return pkginfo { haveTarball = fetched, haddockHtml = if docsExist then haddockHtml pkginfo else "" } +latestWithPref :: Package pkg => VersionRange -> [pkg] -> Maybe pkg+latestWithPref _ [] = Nothing+latestWithPref pref pkgs = Just (maximumBy (comparing prefThenVersion) pkgs)+ where+ prefThenVersion pkg = let ver = packageVersion pkg+ in (withinRange ver pref, ver)++ -- | Rearrange installed and available packages into groups referring to the -- same package by name. In the result pairs, the lists are guaranteed to not -- both be empty. ---mergePackages :: [InstalledPackage] -> [AvailablePackage]- -> [([InstalledPackage], [AvailablePackage])]+mergePackages :: [InstalledPackage]+ -> [AvailablePackage]+ -> [( PackageName+ , [InstalledPackage]+ , [AvailablePackage] )] mergePackages installed available = map collect $ mergeBy (\i a -> fst i `compare` fst a) (groupOn packageName installed) (groupOn packageName available) where- collect (OnlyInLeft (_,is) ) = (is, [])- collect ( InBoth (_,is) (_,as)) = (is, as)- collect (OnlyInRight (_,as)) = ([], as)+ collect (OnlyInLeft (name,is) ) = (name, is, [])+ collect ( InBoth (_,is) (name,as)) = (name, is, as)+ collect (OnlyInRight (name,as)) = (name, [], as) groupOn :: Ord key => (a -> key) -> [a] -> [(key,[a])] groupOn key = map (\xs -> (key (head xs), xs)) . groupBy (equating key) . sortBy (comparing key)++dispTopVersions :: Int -> VersionRange -> [Version] -> Doc+dispTopVersions n pref vs =+ (Disp.fsep . Disp.punctuate (Disp.char ',')+ . map (\ver -> if ispref ver then disp ver else parens (disp ver))+ . sort . take n . interestingVersions ispref+ $ vs)+ <+> trailingMessage++ where+ ispref ver = withinRange ver pref+ extra = length vs - n+ trailingMessage+ | extra <= 0 = Disp.empty+ | otherwise = Disp.parens $ Disp.text "and"+ <+> Disp.int (length vs - n)+ <+> if extra == 1 then Disp.text "other"+ else Disp.text "others"++-- | Reorder a bunch of versions to put the most interesting / significant+-- versions first. A preferred version range is taken into account.+--+-- This may be used in a user interface to select a small number of versions+-- to present to the user, e.g.+--+-- > let selectVersions = sort . take 5 . interestingVersions pref+--+interestingVersions :: (Version -> Bool) -> [Version] -> [Version]+interestingVersions pref =+ map ((\ns -> Version ns []) . fst) . filter snd+ . concat . Tree.levels+ . swizzleTree+ . reorderTree (\(Node (v,_) _) -> pref (Version v []))+ . reverseTree+ . mkTree+ . map versionBranch++ where+ swizzleTree = unfoldTree (spine [])+ where+ spine ts' (Node x []) = (x, ts')+ spine ts' (Node x (t:ts)) = spine (Node x ts:ts') t++ reorderTree _ (Node x []) = Node x []+ reorderTree p (Node x ts) = Node x (ts' ++ ts'')+ where+ (ts',ts'') = partition p (map (reorderTree p) ts)++ reverseTree (Node x cs) = Node x (reverse (map reverseTree cs))++ mkTree xs = unfoldTree step (False, [], xs)+ where+ step (node,ns,vs) =+ ( (reverse ns, node)+ , [ (any null vs', n:ns, filter (not . null) vs')+ | (n, vs') <- groups vs ]+ )+ groups = map (\g -> (head (head g), map tail g))+ . groupBy (equating head)
Distribution/Client/PackageIndex.hs view
@@ -59,7 +59,7 @@ import qualified Data.Graph as Graph import qualified Data.Array as Array import Data.Array ((!))-import Data.List (groupBy, sortBy, nub, find, isInfixOf)+import Data.List (groupBy, sortBy, nub, isInfixOf) import Data.Monoid (Monoid(..)) import Data.Maybe (isNothing, fromMaybe) @@ -283,16 +283,14 @@ -- packages. The list of ambiguous results is split by exact package name. So -- it is a non-empty list of non-empty lists. ---searchByName :: Package pkg => PackageIndex pkg -> String -> SearchResult [pkg]+searchByName :: Package pkg => PackageIndex pkg+ -> String -> [(PackageName, [pkg])] searchByName (PackageIndex m) name =- case [ pkgs | pkgs@(PackageName name',_) <- Map.toList m- , lowercase name' == lname ] of- [] -> None- [(_,pkgs)] -> Unambiguous pkgs- pkgss -> case find ((PackageName name==) . fst) pkgss of- Just (_,pkgs) -> Unambiguous pkgs- Nothing -> Ambiguous (map snd pkgss)- where lname = lowercase name+ [ pkgs+ | pkgs@(PackageName name',_) <- Map.toList m+ , lowercase name' == lname ]+ where+ lname = lowercase name data SearchResult a = None | Unambiguous a | Ambiguous [a] @@ -300,13 +298,14 @@ -- -- That is, all packages that contain the given string in their name. ---searchByNameSubstring :: Package pkg => PackageIndex pkg -> String -> [pkg]+searchByNameSubstring :: Package pkg => PackageIndex pkg+ -> String -> [(PackageName, [pkg])] searchByNameSubstring (PackageIndex m) searchterm =- [ pkg- | (PackageName name, pkgs) <- Map.toList m- , lsearchterm `isInfixOf` lowercase name- , pkg <- pkgs ]- where lsearchterm = lowercase searchterm+ [ pkgs+ | pkgs@(PackageName name, _) <- Map.toList m+ , lsearchterm `isInfixOf` lowercase name ]+ where+ lsearchterm = lowercase searchterm -- -- * Special queries
Distribution/Client/Setup.hs view
@@ -20,10 +20,10 @@ , updateCommand , upgradeCommand , infoCommand, InfoFlags(..)- , fetchCommand+ , fetchCommand, FetchFlags(..) , checkCommand , uploadCommand, UploadFlags(..)- , reportCommand+ , reportCommand, ReportFlags(..) , unpackCommand, UnpackFlags(..) , initCommand, IT.InitFlags(..) @@ -50,7 +50,7 @@ ( ConfigFlags(..) ) import Distribution.Simple.Setup ( Flag(..), toFlag, fromFlag, flagToList, flagToMaybe- , optionVerbosity, trueArg )+ , optionVerbosity, trueArg, falseArg ) import Distribution.Simple.InstallDirs ( PathTemplate, toPathTemplate, fromPathTemplate ) import Distribution.Version@@ -92,7 +92,9 @@ globalConfigFile :: Flag FilePath, globalRemoteRepos :: [RemoteRepo], -- ^Available Hackage servers. globalCacheDir :: Flag FilePath,- globalLocalRepos :: [FilePath]+ globalLocalRepos :: [FilePath],+ globalLogsDir :: Flag FilePath,+ globalWorldFile :: Flag FilePath } defaultGlobalFlags :: GlobalFlags@@ -102,7 +104,9 @@ globalConfigFile = mempty, globalRemoteRepos = [], globalCacheDir = mempty,- globalLocalRepos = mempty+ globalLocalRepos = mempty,+ globalLogsDir = mempty,+ globalWorldFile = mempty } globalCommand :: CommandUI GlobalFlags@@ -152,6 +156,16 @@ "The location of a local repository" globalLocalRepos (\v flags -> flags { globalLocalRepos = v }) (reqArg' "DIR" (\x -> [x]) id)++ ,option [] ["logs-dir"]+ "The location to put log files"+ globalLogsDir (\v flags -> flags { globalLogsDir = v })+ (reqArgFlag "DIR")++ ,option [] ["world-file"]+ "The location of the world file"+ globalWorldFile (\v flags -> flags { globalWorldFile = v })+ (reqArgFlag "FILE") ] } @@ -162,7 +176,9 @@ globalConfigFile = mempty, globalRemoteRepos = mempty, globalCacheDir = mempty,- globalLocalRepos = mempty+ globalLocalRepos = mempty,+ globalLogsDir = mempty,+ globalWorldFile = mempty } mappend a b = GlobalFlags { globalVersion = combine globalVersion,@@ -170,7 +186,9 @@ globalConfigFile = combine globalConfigFile, globalRemoteRepos = combine globalRemoteRepos, globalCacheDir = combine globalCacheDir,- globalLocalRepos = combine globalLocalRepos+ globalLocalRepos = combine globalLocalRepos,+ globalLogsDir = combine globalLogsDir,+ globalWorldFile = combine globalWorldFile } where combine field = field a `mappend` field b @@ -260,19 +278,60 @@ where combine field = field a `mappend` field b -- --------------------------------------------------------------- * Other commands+-- * Fetch command -- ------------------------------------------------------------ -fetchCommand :: CommandUI (Flag Verbosity)+data FetchFlags = FetchFlags {+-- fetchOutput :: Flag FilePath,+ fetchDeps :: Flag Bool,+ fetchDryRun :: Flag Bool,+ fetchVerbosity :: Flag Verbosity+ }++defaultFetchFlags :: FetchFlags+defaultFetchFlags = FetchFlags {+-- fetchOutput = mempty,+ fetchDeps = toFlag True,+ fetchDryRun = toFlag False,+ fetchVerbosity = toFlag normal+ }++fetchCommand :: CommandUI FetchFlags fetchCommand = CommandUI { commandName = "fetch", commandSynopsis = "Downloads packages for later installation.", commandDescription = Nothing, commandUsage = usagePackages "fetch",- commandDefaultFlags = toFlag normal,- commandOptions = \_ -> [optionVerbosity id const]+ commandDefaultFlags = defaultFetchFlags,+ commandOptions = \_ -> [+ optionVerbosity fetchVerbosity (\v flags -> flags { fetchVerbosity = v })++-- , option "o" ["output"]+-- "Put the package(s) somewhere specific rather than the usual cache."+-- fetchOutput (\v flags -> flags { fetchOutput = v })+-- (reqArgFlag "PATH")++ , option [] ["dependencies", "deps"]+ "Resolve and fetch dependencies (default)"+ fetchDeps (\v flags -> flags { fetchDeps = v })+ trueArg++ , option [] ["no-dependencies", "no-deps"]+ "Ignore dependencies"+ fetchDeps (\v flags -> flags { fetchDeps = v })+ falseArg++ , option [] ["dry-run"]+ "Do not install anything, only print what would be installed."+ fetchDryRun (\v flags -> flags { fetchDryRun = v })+ trueArg+ ] } +-- ------------------------------------------------------------+-- * Other commands+-- ------------------------------------------------------------+ updateCommand :: CommandUI (Flag Verbosity) updateCommand = CommandUI { commandName = "update",@@ -286,7 +345,7 @@ upgradeCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags) upgradeCommand = configureCommand { commandName = "upgrade",- commandSynopsis = "Upgrades installed packages to the latest available version",+ commandSynopsis = "(command disabled, use install instead)", commandDescription = Nothing, commandUsage = usagePackages "upgrade", commandDefaultFlags = (mempty, mempty, mempty),@@ -314,16 +373,62 @@ commandOptions = \_ -> [] } -reportCommand :: CommandUI (Flag Verbosity)+-- ------------------------------------------------------------+-- * Report flags+-- ------------------------------------------------------------++data ReportFlags = ReportFlags {+ reportUsername :: Flag Username,+ reportPassword :: Flag Password,+ reportVerbosity :: Flag Verbosity+ }++defaultReportFlags :: ReportFlags+defaultReportFlags = ReportFlags {+ reportUsername = mempty,+ reportPassword = mempty,+ reportVerbosity = toFlag normal+ }++reportCommand :: CommandUI ReportFlags reportCommand = CommandUI { commandName = "report", commandSynopsis = "Upload build reports to a remote server.",- commandDescription = Nothing,- commandUsage = \pname -> "Usage: " ++ pname ++ " report\n",- commandDefaultFlags = toFlag normal,- commandOptions = \_ -> [optionVerbosity id const]+ commandDescription = Just $ \_ ->+ "You can store your Hackage login in the ~/.cabal/config file\n",+ commandUsage = \pname -> "Usage: " ++ pname ++ " report [FLAGS]\n\n"+ ++ "Flags for upload:",+ commandDefaultFlags = defaultReportFlags,+ commandOptions = \_ ->+ [optionVerbosity reportVerbosity (\v flags -> flags { reportVerbosity = v })++ ,option ['u'] ["username"]+ "Hackage username."+ reportUsername (\v flags -> flags { reportUsername = v })+ (reqArg' "USERNAME" (toFlag . Username)+ (flagToList . fmap unUsername))++ ,option ['p'] ["password"]+ "Hackage password."+ reportPassword (\v flags -> flags { reportPassword = v })+ (reqArg' "PASSWORD" (toFlag . Password)+ (flagToList . fmap unPassword))+ ] } +instance Monoid ReportFlags where+ mempty = ReportFlags {+ reportUsername = mempty,+ reportPassword = mempty,+ reportVerbosity = mempty+ }+ mappend a b = ReportFlags {+ reportUsername = combine reportUsername,+ reportPassword = combine reportPassword,+ reportVerbosity = combine reportVerbosity+ }+ where combine field = field a `mappend` field b+ -- ------------------------------------------------------------ -- * Unpack flags -- ------------------------------------------------------------@@ -456,12 +561,15 @@ installHaddockIndex :: Flag PathTemplate, installDryRun :: Flag Bool, installReinstall :: Flag Bool,+ installUpgradeDeps :: Flag Bool, installOnly :: Flag Bool,+ installOnlyDeps :: Flag Bool, installRootCmd :: Flag String, installSummaryFile :: [PathTemplate], installLogFile :: Flag PathTemplate, installBuildReports :: Flag ReportLevel,- installSymlinkBinDir:: Flag FilePath+ installSymlinkBinDir:: Flag FilePath,+ installOneShot :: Flag Bool } defaultInstallFlags :: InstallFlags@@ -470,12 +578,15 @@ installHaddockIndex = Flag docIndexFile, installDryRun = Flag False, installReinstall = Flag False,+ installUpgradeDeps = Flag False, installOnly = Flag False,+ installOnlyDeps = Flag False, installRootCmd = mempty, installSummaryFile = mempty, installLogFile = mempty, installBuildReports = Flag NoReports,- installSymlinkBinDir= mempty+ installSymlinkBinDir= mempty,+ installOneShot = Flag False } where docIndexFile = toPathTemplate ("$datadir" </> "doc" </> "index.html")@@ -533,6 +644,18 @@ installReinstall (\v flags -> flags { installReinstall = v }) trueArg + , option [] ["upgrade-dependencies"]+ "Pick the latest version for all dependencies, rather than trying to pick an installed version."+ installUpgradeDeps (\v flags -> flags { installUpgradeDeps = v })+ trueArg+++ , option [] ["only-dependencies"]+ "Install only the dependencies necessary to build the given packages"+ installOnlyDeps (\v flags -> flags { installOnlyDeps = v })+ trueArg++ , option [] ["root-cmd"] "Command used to gain root privileges, when installing with --global." installRootCmd (\v flags -> flags { installRootCmd = v })@@ -562,6 +685,10 @@ (toFlag `fmap` parse)) (flagToList . fmap display)) + , option [] ["one-shot"]+ "Do not record the packages in the world file."+ installOneShot (\v flags -> flags { installOneShot = v })+ trueArg ] ++ case showOrParseArgs of -- TODO: remove when "cabal install" avoids ParseArgs -> option [] ["only"]@@ -577,24 +704,30 @@ installHaddockIndex = mempty, installDryRun = mempty, installReinstall = mempty,+ installUpgradeDeps = mempty, installOnly = mempty,+ installOnlyDeps = mempty, installRootCmd = mempty, installSummaryFile = mempty, installLogFile = mempty, installBuildReports = mempty,- installSymlinkBinDir= mempty+ installSymlinkBinDir= mempty,+ installOneShot = mempty } mappend a b = InstallFlags { installDocumentation= combine installDocumentation, installHaddockIndex = combine installHaddockIndex, installDryRun = combine installDryRun, installReinstall = combine installReinstall,+ installUpgradeDeps = combine installUpgradeDeps, installOnly = combine installOnly,+ installOnlyDeps = combine installOnlyDeps, installRootCmd = combine installRootCmd, installSummaryFile = combine installSummaryFile, installLogFile = combine installLogFile, installBuildReports = combine installBuildReports,- installSymlinkBinDir= combine installSymlinkBinDir+ installSymlinkBinDir= combine installSymlinkBinDir,+ installOneShot = combine installOneShot } where combine field = field a `mappend` field b
Distribution/Client/SetupWrapper.hs view
@@ -26,14 +26,15 @@ import qualified Distribution.Make as Make import qualified Distribution.Simple as Simple import Distribution.Version- ( Version(..), VersionRange, anyVersion, intersectVersionRanges+ ( Version(..), VersionRange, anyVersion+ , intersectVersionRanges, orLaterVersion , withinRange ) import Distribution.Package ( PackageIdentifier(..), PackageName(..), Package(..), packageName , packageVersion, Dependency(..) ) import Distribution.PackageDescription ( GenericPackageDescription(packageDescription)- , PackageDescription(..), BuildType(..) )+ , PackageDescription(..), specVersion, BuildType(..) ) import Distribution.PackageDescription.Parse ( readPackageDescription ) import Distribution.Simple.Configure@@ -71,7 +72,6 @@ import Control.Monad ( when, unless ) import Data.List ( maximumBy ) import Data.Maybe ( fromMaybe, isJust )-import Data.Monoid ( Monoid(mempty) ) import Data.Char ( isSpace ) data SetupScriptOptions = SetupScriptOptions {@@ -110,7 +110,7 @@ options' = options { useCabalVersion = intersectVersionRanges (useCabalVersion options)- (descCabalVersion pkg)+ (orLaterVersion (specVersion pkg)) } buildType' = fromMaybe Custom (buildType pkg) mkArgs cabalLibVersion = commandName cmd@@ -207,8 +207,7 @@ installedCabalVersion options' comp conf = do index <- case usePackageIndex options' of Just index -> return index- Nothing -> fromMaybe mempty- `fmap` getInstalledPackages verbosity+ Nothing -> getInstalledPackages verbosity comp (usePackageDB options') conf let cabalDep = Dependency (PackageName "Cabal") (useCabalVersion options)
Distribution/Client/Tar.hs view
@@ -7,7 +7,7 @@ -- 2008-2009 Duncan Coutts -- License : BSD3 ----- Maintainer : duncan@haskell.org+-- Maintainer : duncan@community.haskell.org -- Portability : portable -- -- Reading, writing and manipulating \"@.tar@\" archive files.@@ -51,23 +51,27 @@ -- ** Sequences of tar entries Entries(..),- foldEntries,- unfoldEntries,+ foldrEntries,+ foldlEntries,+ unfoldrEntries, mapEntries,+ filterEntries,+ entriesIndex, ) where import Data.Char (ord) import Data.Int (Int64)-import Data.Bits (Bits, shiftL)+import Data.Bits (Bits, shiftL, testBit) import Data.List (foldl') import Numeric (readOct, showOct)-import Control.Monad (MonadPlus(mplus))-+import Control.Monad (MonadPlus(mplus), when)+import qualified Data.Map as Map import qualified Data.ByteString.Lazy as BS import qualified Data.ByteString.Lazy.Char8 as BS.Char8 import Data.ByteString.Lazy (ByteString) import qualified Codec.Compression.GZip as GZip+import qualified Distribution.Client.GZipUtils as GZipUtils import System.FilePath ( (</>) )@@ -79,6 +83,8 @@ , getPermissions, createDirectoryIfMissing, copyFile ) import qualified System.Directory as Permissions ( Permissions(executable) )+import Distribution.Compat.FilePerms+ ( setFileExecutable ) import System.Posix.Types ( FileMode ) import System.Time@@ -105,8 +111,8 @@ -> FilePath -- ^ Expected subdir (to check for tarbombs) -> FilePath -- ^ Tarball -> IO ()-extractTarGzFile dir expected tar =- unpack dir . checkTarbomb expected . read . GZip.decompress =<< BS.readFile tar+extractTarGzFile dir expected tar = do+ unpack dir . checkTarbomb expected . read . GZipUtils.maybeDecompress =<< BS.readFile tar -- -- * Entry type@@ -212,6 +218,9 @@ directoryPermissions :: Permissions directoryPermissions = 0o0755 +isExecutable :: Permissions -> Bool+isExecutable p = testBit p 0 || testBit p 6 -- user or other exectuable+ -- | An 'Entry' with all default values except for the file name and type. It -- uses the portable USTAR/POSIX format (see 'UstarHeader'). --@@ -381,25 +390,50 @@ | Done | Fail String -unfoldEntries :: (a -> Either String (Maybe (Entry, a))) -> a -> Entries-unfoldEntries f = unfold+unfoldrEntries :: (a -> Either String (Maybe (Entry, a))) -> a -> Entries+unfoldrEntries f = unfold where unfold x = case f x of Left err -> Fail err Right Nothing -> Done Right (Just (e, x')) -> Next e (unfold x') -foldEntries :: (Entry -> a -> a) -> a -> (String -> a) -> Entries -> a-foldEntries next done fail' = fold+foldrEntries :: (Entry -> a -> a) -> a -> (String -> a) -> Entries -> a+foldrEntries next done fail' = fold where fold (Next e es) = next e (fold es) fold Done = done fold (Fail err) = fail' err -mapEntries :: (Entry -> Either String Entry) -> Entries -> Entries-mapEntries f =- foldEntries (\entry rest -> either Fail (flip Next rest) (f entry)) Done Fail+foldlEntries :: (a -> Entry -> a) -> a -> Entries -> Either String a+foldlEntries f = fold+ where+ fold a (Next e es) = (fold $! f a e) es+ fold a Done = Right a+ fold _ (Fail err) = Left err +mapEntries :: (Entry -> Entry) -> Entries -> Entries+mapEntries f = foldrEntries (Next . f) Done Fail++filterEntries :: (Entry -> Bool) -> Entries -> Entries+filterEntries p =+ foldrEntries+ (\entry rest -> if p entry+ then Next entry rest+ else rest)+ Done Fail++checkEntries :: (Entry -> Maybe String) -> Entries -> Entries+checkEntries checkEntry =+ foldrEntries+ (\entry rest -> case checkEntry entry of+ Nothing -> Next entry rest+ Just err -> Fail err)+ Done Fail++entriesIndex :: Entries -> Either String (Map.Map TarPath Entry)+entriesIndex = foldlEntries (\m e -> Map.insert (entryTarPath e) e m) Map.empty+ -- -- * Checking --@@ -462,16 +496,13 @@ _ -> Just $ "File in tar archive is not in the expected directory " ++ show expectedTopDir -checkEntries :: (Entry -> Maybe String) -> Entries -> Entries-checkEntries checkEntry =- mapEntries (\entry -> maybe (Right entry) Left (checkEntry entry)) -- -- * Reading -- read :: ByteString -> Entries-read = unfoldEntries getEntry+read = unfoldrEntries getEntry getEntry :: ByteString -> Either String (Maybe (Entry, ByteString)) getEntry bs@@ -740,7 +771,7 @@ unpackEntries _ (Fail err) = fail err unpackEntries links Done = return links unpackEntries links (Next entry es) = case entryContent entry of- NormalFile file _ -> extractFile path file+ NormalFile file _ -> extractFile entry path file >> unpackEntries links es Directory -> extractDir path >> unpackEntries links es@@ -750,12 +781,14 @@ where path = entryPath entry - extractFile path content = do+ extractFile entry path content = do -- Note that tar archives do not make sure each directory is created -- before files they contain, indeed we may have to create several -- levels of directory. createDirectoryIfMissing True absDir BS.writeFile absPath content+ when (isExecutable (entryPermissions entry))+ (setFileExecutable absPath) where absDir = baseDir </> FilePath.Native.takeDirectory path absPath = baseDir </> path
+ Distribution/Client/Targets.hs view
@@ -0,0 +1,650 @@+-----------------------------------------------------------------------------+-- |+-- Module : Distribution.Client.Targets+-- Copyright : (c) Duncan Coutts 2011+-- License : BSD-like+--+-- Maintainer : duncan@community.haskell.org+--+-- Handling for user-specified targets+-----------------------------------------------------------------------------+module Distribution.Client.Targets (+ -- * User targets+ UserTarget(..),+ readUserTargets,++ -- * Package specifiers+ PackageSpecifier(..),+ pkgSpecifierTarget,+ pkgSpecifierConstraints,++ -- * Resolving user targets to package specifiers+ resolveUserTargets,++ -- ** Detailed interface+ UserTargetProblem(..),+ readUserTarget,+ reportUserTargetProblems,+ expandUserTarget,++ PackageTarget(..),+ fetchPackageTarget,+ readPackageTarget,++ PackageTargetProblem(..),+ reportPackageTargetProblems,++ disambiguatePackageTargets,+ disambiguatePackageName,++ ) where++import Distribution.Package+ ( Package(..), PackageName(..)+ , PackageIdentifier(..), packageName, packageVersion+ , Dependency(Dependency) )+import Distribution.Client.Types+ ( AvailablePackage(..), PackageLocation(..) )+import Distribution.Client.Dependency.Types+ ( PackageConstraint(..) )++import qualified Distribution.Client.World as World+import Distribution.Client.PackageIndex (PackageIndex)+import qualified Distribution.Client.PackageIndex as PackageIndex+import qualified Distribution.Client.Tar as Tar+import Distribution.Client.FetchUtils++import Distribution.PackageDescription+ ( GenericPackageDescription )+import Distribution.PackageDescription.Parse+ ( readPackageDescription, parsePackageDescription, ParseResult(..) )+import Distribution.Simple.Setup+ ( fromFlag )+import Distribution.Client.Setup+ ( GlobalFlags(..) )+import Distribution.Version+ ( Version(Version), thisVersion, anyVersion, isAnyVersion )+import Distribution.Text+ ( Text(parse), display )+import Distribution.Verbosity (Verbosity)+import Distribution.Simple.Utils+ ( die, warn, intercalate, findPackageDesc, fromUTF8, lowercase )++import Data.List+ ( find, nub )+import Data.Maybe+ ( listToMaybe )+import Data.Either+ ( partitionEithers )+import Data.Monoid+ ( Monoid(..) )+import qualified Data.Map as Map+import qualified Data.ByteString.Lazy as BS+import qualified Data.ByteString.Lazy.Char8 as BS.Char8+import qualified Distribution.Client.GZipUtils as GZipUtils+import Control.Monad (liftM)+import qualified Distribution.Compat.ReadP as Parse+ ( ReadP, readP_to_S, (+++) )+import Data.Char+ ( isSpace )+import System.FilePath+ ( takeExtension, dropExtension, takeDirectory, splitPath )+import System.Directory+ ( doesFileExist, doesDirectoryExist )+import Network.URI+ ( URI(..), URIAuth(..), parseAbsoluteURI )++-- ------------------------------------------------------------+-- * User targets+-- ------------------------------------------------------------++-- | Various ways that a user may specify a package or package collection.+--+data UserTarget =++ -- | A partially specified package, identified by name and possibly with+ -- an exact version or a version constraint.+ --+ -- > cabal install foo+ -- > cabal install foo-1.0+ -- > cabal install 'foo < 2'+ --+ UserTargetNamed Dependency++ -- | A special virtual package that refers to the collection of packages+ -- recorded in the world file that the user specifically installed.+ --+ -- > cabal install world+ --+ | UserTargetWorld++ -- | A specific package that is unpacked in a local directory, often the+ -- current directory.+ --+ -- > cabal install .+ -- > cabal install ../lib/other+ --+ -- * Note: in future, if multiple @.cabal@ files are allowed in a single+ -- directory then this will refer to the collection of packages.+ --+ | UserTargetLocalDir FilePath++ -- | A specific local unpacked package, identified by its @.cabal@ file.+ --+ -- > cabal install foo.cabal+ -- > cabal install ../lib/other/bar.cabal+ --+ | UserTargetLocalCabalFile FilePath++ -- | A specific package that is available as a local tarball file+ --+ -- > cabal install dist/foo-1.0.tar.gz+ -- > cabal install ../build/baz-1.0.tar.gz+ --+ | UserTargetLocalTarball FilePath++ -- | A specific package that is available as a remote tarball file+ --+ -- > cabal install http://code.haskell.org/~user/foo/foo-0.9.tar.gz+ --+ | UserTargetRemoteTarball URI+ deriving (Show,Eq)+++-- ------------------------------------------------------------+-- * Package specifier+-- ------------------------------------------------------------++-- | A fully or partially resolved reference to a package.+--+data PackageSpecifier pkg =++ -- | A partially specified reference to a package (either source or+ -- installed). It is specified by package name and optionally some+ -- additional constraints. Use a dependency resolver to pick a specific+ -- package satisfying these constraints.+ --+ NamedPackage PackageName [PackageConstraint]++ -- | A fully specified source package.+ --+ | SpecificSourcePackage pkg+ deriving Show+++pkgSpecifierTarget :: Package pkg => PackageSpecifier pkg -> PackageName+pkgSpecifierTarget (NamedPackage name _) = name+pkgSpecifierTarget (SpecificSourcePackage pkg) = packageName pkg++pkgSpecifierConstraints :: Package pkg+ => PackageSpecifier pkg -> [PackageConstraint]+pkgSpecifierConstraints (NamedPackage _ constraints) = constraints+pkgSpecifierConstraints (SpecificSourcePackage pkg) =+ [PackageVersionConstraint (packageName pkg)+ (thisVersion (packageVersion pkg))]+++-- ------------------------------------------------------------+-- * Parsing and checking user targets+-- ------------------------------------------------------------++readUserTargets :: Verbosity -> [String] -> IO [UserTarget]+readUserTargets _verbosity targetStrs = do+ (problems, targets) <- liftM partitionEithers+ (mapM readUserTarget targetStrs)+ reportUserTargetProblems problems+ return targets+++data UserTargetProblem+ = UserTargetUnexpectedFile String+ | UserTargetNonexistantFile String+ | UserTargetUnexpectedUriScheme String+ | UserTargetUnrecognisedUri String+ | UserTargetUnrecognised String+ deriving Show++readUserTarget :: String -> IO (Either UserTargetProblem UserTarget)+readUserTarget targetstr =+ case testNamedTargets targetstr of+ Just target -> return target+ Nothing -> do+ fileTarget <- testFileTargets targetstr+ case fileTarget of+ Just target -> return target+ Nothing ->+ case testUriTargets targetstr of+ Just target -> return target+ Nothing -> return (Left (UserTargetUnrecognised targetstr))+ where+ testNamedTargets = fmap (Right . UserTargetNamed)+ . readPToMaybe parseDependencyOrPackageId++ testFileTargets filename = do+ isDir <- doesDirectoryExist filename+ isFile <- doesFileExist filename+ parentDirExists <- case takeDirectory filename of+ [] -> return False+ dir -> doesDirectoryExist dir+ let result+ | isDir+ = Just (Right (UserTargetLocalDir filename))++ | isFile && extensionIsTarGz filename+ = Just (Right (UserTargetLocalTarball filename))++ | isFile && takeExtension filename == ".cabal"+ = Just (Right (UserTargetLocalCabalFile filename))++ | isFile+ = Just (Left (UserTargetUnexpectedFile filename))++ | parentDirExists+ = Just (Left (UserTargetNonexistantFile filename))++ | otherwise+ = Nothing+ return result++ testUriTargets str =+ case parseAbsoluteURI str of+ Just uri@URI {+ uriScheme = scheme,+ uriAuthority = Just URIAuth { uriRegName = host }+ }+ | scheme /= "http:" ->+ Just (Left (UserTargetUnexpectedUriScheme targetstr))++ | null host ->+ Just (Left (UserTargetUnrecognisedUri targetstr))++ | otherwise ->+ Just (Right (UserTargetRemoteTarball uri))+ _ -> Nothing++ extensionIsTarGz f = takeExtension f == ".gz"+ && takeExtension (dropExtension f) == ".tar"++ parseDependencyOrPackageId :: Parse.ReadP r Dependency+ parseDependencyOrPackageId = parse Parse.+++ liftM pkgidToDependency parse+ where+ pkgidToDependency :: PackageIdentifier -> Dependency+ pkgidToDependency p = case packageVersion p of+ Version [] _ -> Dependency (packageName p) anyVersion+ version -> Dependency (packageName p) (thisVersion version)++ readPToMaybe :: Parse.ReadP a a -> String -> Maybe a+ readPToMaybe p str = listToMaybe [ r | (r,s) <- Parse.readP_to_S p str+ , all isSpace s ]+++reportUserTargetProblems :: [UserTargetProblem] -> IO ()+reportUserTargetProblems problems = do+ case [ target | UserTargetUnrecognised target <- problems ] of+ [] -> return ()+ target -> die+ $ unlines+ [ "Unrecognised target '" ++ name ++ "'."+ | name <- target ]+ ++ "Targets can be:\n"+ ++ " - package names, e.g. 'pkgname', 'pkgname-1.0.1', 'pkgname < 2.0'\n"+ ++ " - the special 'world' target\n"+ ++ " - cabal files 'pkgname.cabal' or package directories 'pkgname/'\n"+ ++ " - package tarballs 'pkgname.tar.gz' or 'http://example.com/pkgname.tar.gz'"++ case [ target | UserTargetNonexistantFile target <- problems ] of+ [] -> return ()+ target -> die+ $ unlines+ [ "The file does not exist '" ++ name ++ "'."+ | name <- target ]++ case [ target | UserTargetUnexpectedFile target <- problems ] of+ [] -> return ()+ target -> die+ $ unlines+ [ "Unrecognised file target '" ++ name ++ "'."+ | name <- target ]+ ++ "File targets can be either package tarballs 'pkgname.tar.gz' "+ ++ "or cabal files 'pkgname.cabal'."++ case [ target | UserTargetUnexpectedUriScheme target <- problems ] of+ [] -> return ()+ target -> die+ $ unlines+ [ "URL target not supported '" ++ name ++ "'."+ | name <- target ]+ ++ "Only 'http://' URLs are supported."++ case [ target | UserTargetUnrecognisedUri target <- problems ] of+ [] -> return ()+ target -> die+ $ unlines+ [ "Unrecognise URL target '" ++ name ++ "'."+ | name <- target ]+++-- ------------------------------------------------------------+-- * Resolving user targets to package specifiers+-- ------------------------------------------------------------++-- | Given a bunch of user-specified targets, try to resolve what it is they+-- refer to. They can either be specific packages (local dirs, tarballs etc)+-- or they can be named packages (with or without version info).+--+resolveUserTargets :: Package pkg+ => Verbosity+ -> GlobalFlags+ -> PackageIndex pkg+ -> [UserTarget]+ -> IO [PackageSpecifier AvailablePackage]+resolveUserTargets verbosity globalFlags available userTargets = do++ -- given the user targets, get a list of fully or partially resolved+ -- package references+ packageTargets <- mapM (readPackageTarget verbosity)+ =<< mapM (fetchPackageTarget verbosity) . concat+ =<< mapM (expandUserTarget globalFlags) userTargets++ -- users are allowed to give package names case-insensitively, so we must+ -- disambiguate named package references+ let (problems, packageSpecifiers) =+ disambiguatePackageTargets available availableExtra packageTargets++ -- use any extra specific available packages to help us disambiguate+ availableExtra = [ packageName pkg+ | PackageTargetLocation pkg <- packageTargets ]++ reportPackageTargetProblems verbosity problems++ return packageSpecifiers+++-- ------------------------------------------------------------+-- * Package targets+-- ------------------------------------------------------------++-- | An intermediate between a 'UserTarget' and a resolved 'PackageSpecifier'.+-- Unlike a 'UserTarget', a 'PackageTarget' refers only to a single package.+--+data PackageTarget pkg =+ PackageTargetNamed PackageName [PackageConstraint] UserTarget++ -- | A package identified by name, but case insensitively, so it needs+ -- to be resolved to the right case-sensitive name.+ | PackageTargetNamedFuzzy PackageName [PackageConstraint] UserTarget+ | PackageTargetLocation pkg+ deriving Show+++-- ------------------------------------------------------------+-- * Converting user targets to package targets+-- ------------------------------------------------------------++-- | Given a user-specified target, expand it to a bunch of package targets+-- (each of which refers to only one package).+--+expandUserTarget :: GlobalFlags+ -> UserTarget+ -> IO [PackageTarget (PackageLocation ())]+expandUserTarget globalFlags userTarget = case userTarget of++ UserTargetNamed (Dependency name vrange) ->+ let constraints = [ PackageVersionConstraint name vrange+ | not (isAnyVersion vrange) ]+ in return [PackageTargetNamedFuzzy name constraints userTarget]++ UserTargetWorld -> do+ worldPkgs <- World.getContents worldFile+ --TODO: should we warn if there are no world targets?+ return [ PackageTargetNamed name constraints userTarget+ | World.WorldPkgInfo (Dependency name vrange) flags <- worldPkgs+ , let constraints = [ PackageVersionConstraint name vrange+ | not (isAnyVersion vrange) ]+ ++ [ PackageFlagsConstraint name flags+ | not (null flags) ] ]++ UserTargetLocalDir dir ->+ return [ PackageTargetLocation (LocalUnpackedPackage dir) ]++ UserTargetLocalCabalFile file -> do+ let dir = takeDirectory file+ _ <- findPackageDesc dir -- just as a check+ return [ PackageTargetLocation (LocalUnpackedPackage dir) ]++ UserTargetLocalTarball tarballFile ->+ return [ PackageTargetLocation (LocalTarballPackage tarballFile) ]++ UserTargetRemoteTarball tarballURL ->+ return [ PackageTargetLocation (RemoteTarballPackage tarballURL ()) ]+ where+ worldFile = fromFlag $ globalWorldFile globalFlags+++-- ------------------------------------------------------------+-- * Fetching and reading package targets+-- ------------------------------------------------------------+++-- | Fetch any remote targets so that they can be read.+--+fetchPackageTarget :: Verbosity+ -> PackageTarget (PackageLocation ())+ -> IO (PackageTarget (PackageLocation FilePath))+fetchPackageTarget verbosity target = case target of+ PackageTargetNamed n cs ut -> return (PackageTargetNamed n cs ut)+ PackageTargetNamedFuzzy n cs ut -> return (PackageTargetNamedFuzzy n cs ut)+ PackageTargetLocation location -> do+ location' <- fetchPackage verbosity (fmap (const Nothing) location)+ return (PackageTargetLocation location')+++-- | Given a package target that has been fetched, read the .cabal file.+--+-- This only affects targets given by location, named targets are unaffected.+--+readPackageTarget :: Verbosity+ -> PackageTarget (PackageLocation FilePath)+ -> IO (PackageTarget AvailablePackage)+readPackageTarget verbosity target = case target of++ PackageTargetNamed pkgname constraints userTarget ->+ return (PackageTargetNamed pkgname constraints userTarget)++ PackageTargetNamedFuzzy pkgname constraints userTarget ->+ return (PackageTargetNamedFuzzy pkgname constraints userTarget)++ PackageTargetLocation location -> case location of++ LocalUnpackedPackage dir -> do+ pkg <- readPackageDescription verbosity =<< findPackageDesc dir+ return $ PackageTargetLocation $+ AvailablePackage {+ packageInfoId = packageId pkg,+ packageDescription = pkg,+ packageSource = fmap Just location+ }++ LocalTarballPackage tarballFile ->+ readTarballPackageTarget location tarballFile tarballFile++ RemoteTarballPackage tarballURL tarballFile ->+ readTarballPackageTarget location tarballFile (show tarballURL)++ RepoTarballPackage _repo _pkgid _ ->+ error "TODO: readPackageTarget RepoTarballPackage"+ -- For repo tarballs this info should be obtained from the index.++ where+ readTarballPackageTarget location tarballFile tarballOriginalLoc = do+ (filename, content) <- extractTarballPackageCabalFile+ tarballFile tarballOriginalLoc+ case parsePackageDescription' content of+ Nothing -> die $ "Could not parse the cabal file "+ ++ filename ++ " in " ++ tarballFile+ Just pkg ->+ return $ PackageTargetLocation $+ AvailablePackage {+ packageInfoId = packageId pkg,+ packageDescription = pkg,+ packageSource = fmap Just location+ }++ extractTarballPackageCabalFile :: FilePath -> String+ -> IO (FilePath, BS.ByteString)+ extractTarballPackageCabalFile tarballFile tarballOriginalLoc =+ either (die . formatErr) return+ . check+ . Tar.entriesIndex+ . Tar.filterEntries isCabalFile+ . Tar.read+ . GZipUtils.maybeDecompress+ =<< BS.readFile tarballFile+ where+ formatErr msg = "Error reading " ++ tarballOriginalLoc ++ ": " ++ msg++ check (Left e) = Left e+ check (Right m) = case Map.elems m of+ [] -> Left noCabalFile+ [file] -> case Tar.entryContent file of+ Tar.NormalFile content _ -> Right (Tar.entryPath file, content)+ _ -> Left noCabalFile+ _files -> Left multipleCabalFiles+ where+ noCabalFile = "No cabal file found"+ multipleCabalFiles = "Multiple cabal files found"++ isCabalFile e = case splitPath (Tar.entryPath e) of+ [ _dir, file] -> takeExtension file == ".cabal"+ [".", _dir, file] -> takeExtension file == ".cabal"+ _ -> False++ parsePackageDescription' :: BS.ByteString -> Maybe GenericPackageDescription+ parsePackageDescription' content =+ case parsePackageDescription . fromUTF8 . BS.Char8.unpack $ content of+ ParseOk _ pkg -> Just pkg+ _ -> Nothing+++-- ------------------------------------------------------------+-- * Checking package targets+-- ------------------------------------------------------------++data PackageTargetProblem+ = PackageNameUnknown PackageName UserTarget+ | PackageNameAmbigious PackageName [PackageName] UserTarget+ deriving Show+++-- | Users are allowed to give package names case-insensitively, so we must+-- disambiguate named package references.+--+disambiguatePackageTargets :: Package pkg'+ => PackageIndex pkg'+ -> [PackageName]+ -> [PackageTarget pkg]+ -> ( [PackageTargetProblem]+ , [PackageSpecifier pkg] )+disambiguatePackageTargets available availableExtra targets =+ partitionEithers (map disambiguatePackageTarget targets)+ where+ disambiguatePackageTarget packageTarget = case packageTarget of+ PackageTargetLocation pkg -> Right (SpecificSourcePackage pkg)++ PackageTargetNamed pkgname constraints userTarget+ | null (PackageIndex.lookupPackageName available pkgname)+ -> Left (PackageNameUnknown pkgname userTarget)+ | otherwise -> Right (NamedPackage pkgname constraints)++ PackageTargetNamedFuzzy pkgname constraints userTarget ->+ case disambiguatePackageName packageNameEnv pkgname of+ None -> Left (PackageNameUnknown+ pkgname userTarget)+ Ambiguous pkgnames -> Left (PackageNameAmbigious+ pkgname pkgnames userTarget)+ Unambiguous pkgname' -> Right (NamedPackage pkgname' constraints)++ -- use any extra specific available packages to help us disambiguate+ packageNameEnv :: PackageNameEnv+ packageNameEnv = mappend (indexPackageNameEnv available)+ (extraPackageNameEnv availableExtra)+++-- | Report problems to the user. That is, if there are any problems+-- then raise an exception.+reportPackageTargetProblems :: Verbosity+ -> [PackageTargetProblem] -> IO ()+reportPackageTargetProblems verbosity problems = do+ case [ pkg | PackageNameUnknown pkg originalTarget <- problems+ , not (isUserTagetWorld originalTarget) ] of+ [] -> return ()+ pkgs -> die $ unlines+ [ "There is no package named '" ++ display name ++ "'. "+ | name <- pkgs ]+ ++ "You may need to run 'cabal update' to get the latest "+ ++ "list of available packages."++ case [ (pkg, matches) | PackageNameAmbigious pkg matches _ <- problems ] of+ [] -> return ()+ ambiguities -> die $ unlines+ [ "The package name '" ++ display name+ ++ "' is ambigious. It could be: "+ ++ intercalate ", " (map display matches)+ | (name, matches) <- ambiguities ]++ case [ pkg | PackageNameUnknown pkg UserTargetWorld <- problems ] of+ [] -> return ()+ pkgs -> warn verbosity $+ "The following 'world' packages will be ignored because "+ ++ "they refer to packages that cannot be found: "+ ++ intercalate ", " (map display pkgs) ++ "\n"+ ++ "You can surpress this warning by correcting the world file."+ where+ isUserTagetWorld UserTargetWorld = True; isUserTagetWorld _ = False+++-- ------------------------------------------------------------+-- * Disambiguating package names+-- ------------------------------------------------------------++data MaybeAmbigious a = None | Unambiguous a | Ambiguous [a]++-- | Given a package name and a list of matching names, figure out which one it+-- might be referring to. If there is an exact case-sensitive match then that's+-- ok. If it matches just one package case-insensitively then that's also ok.+-- The only problem is if it matches multiple packages case-insensitively, in+-- that case it is ambigious.+--+disambiguatePackageName :: PackageNameEnv+ -> PackageName+ -> MaybeAmbigious PackageName+disambiguatePackageName (PackageNameEnv pkgNameLookup) name =+ case nub (pkgNameLookup name) of+ [] -> None+ [name'] -> Unambiguous name'+ names -> case find (name==) names of+ Just name' -> Unambiguous name'+ Nothing -> Ambiguous names+++newtype PackageNameEnv = PackageNameEnv (PackageName -> [PackageName])++instance Monoid PackageNameEnv where+ mempty = PackageNameEnv (const [])+ mappend (PackageNameEnv lookupA) (PackageNameEnv lookupB) =+ PackageNameEnv (\name -> lookupA name ++ lookupB name)++indexPackageNameEnv :: Package pkg => PackageIndex pkg -> PackageNameEnv+indexPackageNameEnv index = PackageNameEnv pkgNameLookup+ where+ pkgNameLookup (PackageName name) =+ map fst (PackageIndex.searchByName index name)++extraPackageNameEnv :: [PackageName] -> PackageNameEnv+extraPackageNameEnv names = PackageNameEnv pkgNameLookup+ where+ pkgNameLookup (PackageName name) =+ [ PackageName name'+ | let lname = lowercase name+ , PackageName name' <- names+ , lowercase name' == lname ]
Distribution/Client/Types.hs view
@@ -2,19 +2,19 @@ -- | -- Module : Distribution.Client.Types -- Copyright : (c) David Himmelstrup 2005+-- Duncan Coutts 2011 -- License : BSD-like ----- Maintainer : lemmih@gmail.com+-- Maintainer : cabal-devel@haskell.org -- Stability : provisional -- Portability : portable ----- All data types for the entire cabal-install system gathered here to avoid some .hs-boot files.+-- Various common data types for the entire cabal-install system ----------------------------------------------------------------------------- module Distribution.Client.Types where import Distribution.Package- ( PackageName, PackageId, Package(..)- , PackageFixedDeps(..), Dependency )+ ( PackageName, PackageId, Package(..), PackageFixedDeps(..) ) import Distribution.InstalledPackageInfo ( InstalledPackageInfo ) import Distribution.PackageDescription@@ -39,6 +39,10 @@ packagePreferences :: Map PackageName VersionRange } +-- ------------------------------------------------------------+-- * Various kinds of information about packages+-- ------------------------------------------------------------+ -- | TODO: This is a hack to help us transition from Cabal-1.6 to 1.8. -- What is new in 1.8 is that installed packages and dependencies between -- installed packages are now identified by an opaque InstalledPackageId@@ -88,31 +92,45 @@ data AvailablePackage = AvailablePackage { packageInfoId :: PackageId, packageDescription :: GenericPackageDescription,- packageSource :: AvailablePackageSource+ packageSource :: PackageLocation (Maybe FilePath) } deriving Show instance Package AvailablePackage where packageId = packageInfoId -data AvailablePackageSource =+-- ------------------------------------------------------------+-- * Package locations and repositories+-- ------------------------------------------------------------ - -- | The unpacked package in the current dir- LocalUnpackedPackage+data PackageLocation local = + -- | An unpacked package in the given dir, or current dir+ LocalUnpackedPackage FilePath++ -- | A package as a tarball that's available as a local tarball+ | LocalTarballPackage FilePath++ -- | A package as a tarball from a remote URI+ | RemoteTarballPackage URI local+ -- | A package available as a tarball from a repository. -- -- It may be from a local repository or from a remote repository, with a -- locally cached copy. ie a package available from hackage- | RepoTarballPackage Repo+ | RepoTarballPackage Repo PackageId local +--TODO:+-- * add support for darcs and other SCM style remote repos with a local cache -- | ScmPackage deriving Show ---TODO:--- * generalise local package to any local unpacked package, not just in the--- current dir, ie add a FilePath param--- * add support for darcs and other SCM style remote repos with a local cache+instance Functor PackageLocation where+ fmap _ (LocalUnpackedPackage dir) = LocalUnpackedPackage dir+ fmap _ (LocalTarballPackage file) = LocalTarballPackage file+ fmap f (RemoteTarballPackage uri x) = RemoteTarballPackage uri (f x)+ fmap f (RepoTarballPackage repo pkg x) = RepoTarballPackage repo pkg (f x) + data LocalRepo = LocalRepo deriving (Show,Eq) @@ -128,12 +146,9 @@ } deriving (Show,Eq) -data UnresolvedDependency- = UnresolvedDependency- { dependency :: Dependency- , depFlags :: FlagAssignment- }- deriving (Show)+-- ------------------------------------------------------------+-- * Build results+-- ------------------------------------------------------------ type BuildResult = Either BuildFailure BuildSuccess data BuildFailure = DependentFailed PackageId
Distribution/Client/Unpack.hs view
@@ -2,6 +2,7 @@ -- | -- Module : Distribution.Client.Unpack -- Copyright : (c) Andrea Vezzosi 2008+-- Duncan Coutts 2011 -- License : BSD-like -- -- Maintainer : cabal-devel@haskell.org@@ -18,72 +19,93 @@ ) where import Distribution.Package- ( PackageId, packageId, Dependency(..) )-import Distribution.Client.PackageIndex as PackageIndex (lookupDependency)-import Distribution.Simple.Setup(fromFlag, fromFlagOrDefault)+ ( PackageId, packageId )+import Distribution.Simple.Setup+ ( fromFlagOrDefault ) import Distribution.Simple.Utils ( notice, die ) import Distribution.Verbosity ( Verbosity ) import Distribution.Text(display)-import Distribution.Version- ( anyVersion, intersectVersionRanges ) -import Distribution.Client.Setup(UnpackFlags(unpackVerbosity,- unpackDestDir))-import Distribution.Client.Types(UnresolvedDependency(..),- Repo, AvailablePackageSource(..),- AvailablePackage(AvailablePackage),- AvailablePackageDb(AvailablePackageDb))-import Distribution.Client.Fetch(fetchPackage)+import Distribution.Client.Setup+ ( GlobalFlags(..), UnpackFlags(..) )+import Distribution.Client.Types+import Distribution.Client.Targets+import Distribution.Client.Dependency+import Distribution.Client.FetchUtils import qualified Distribution.Client.Tar as Tar (extractTarGzFile) import Distribution.Client.IndexUtils as IndexUtils- (getAvailablePackages, disambiguateDependencies)+ ( getAvailablePackages ) import System.Directory ( createDirectoryIfMissing, doesDirectoryExist, doesFileExist ) import Control.Monad ( unless, when )-import Data.Ord (comparing)-import Data.List(maximumBy)+import Data.Monoid+ ( mempty ) import System.FilePath ( (</>), addTrailingPathSeparator )-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'+unpack :: Verbosity+ -> [Repo]+ -> GlobalFlags+ -> UnpackFlags+ -> [UserTarget] + -> IO ()+unpack verbosity _ _ _ [] =+ notice verbosity "No packages requested. Nothing to do." +unpack verbosity repos globalFlags unpackFlags userTargets = do+ mapM_ checkTarget userTargets++ availableDb <- getAvailablePackages verbosity repos++ pkgSpecifiers <- resolveUserTargets verbosity+ globalFlags (packageIndex availableDb) userTargets++ pkgs <- either (die . unlines . map show) return $+ resolveWithoutDependencies+ (resolverParams availableDb pkgSpecifiers)+ unless (null prefix) $ createDirectoryIfMissing True prefix - flip mapM_ pkgs $ \pkg ->- case pkg of+ flip mapM_ pkgs $ \pkg -> do+ location <- fetchPackage verbosity (packageSource pkg)+ let pkgid = packageId pkg+ case location of+ LocalTarballPackage tarballPath ->+ unpackPackage verbosity prefix pkgid tarballPath - Left (Dependency name ver) -> - die $ "There is no available version of " ++ display name - ++ " that satisfies " ++ display ver+ RemoteTarballPackage _tarballURL tarballPath ->+ unpackPackage verbosity prefix pkgid tarballPath - Right (AvailablePackage pkgid _ (RepoTarballPackage repo)) -> do- pkgPath <- fetchPackage verbosity repo pkgid- unpackPackage verbosity prefix pkgid pkgPath+ RepoTarballPackage _repo _pkgid tarballPath ->+ unpackPackage verbosity prefix pkgid tarballPath - Right (AvailablePackage _ _ LocalUnpackedPackage) -> - error "Distribution.Client.Unpack.unpack: the impossible happened."- where - verbosity = fromFlag (unpackVerbosity flags)- prefix = fromFlagOrDefault "" (unpackDestDir flags)- toUnresolved d = UnresolvedDependency d []+ LocalUnpackedPackage _ ->+ error "Distribution.Client.Unpack.unpack: the impossible happened." + where+ resolverParams availableDb pkgSpecifiers =+ --TODO: add commandline constraint and preference args for unpack++ standardInstallPolicy mempty availableDb pkgSpecifiers++ prefix = fromFlagOrDefault "" (unpackDestDir unpackFlags)++checkTarget :: UserTarget -> IO ()+checkTarget target = case target of+ UserTargetLocalDir dir -> die (notTarball dir)+ UserTargetLocalCabalFile file -> die (notTarball file)+ _ -> return ()+ where+ notTarball t =+ "The 'unpack' command is for tarball packages. "+ ++ "The target '" ++ t ++ "' is not a tarball."+ unpackPackage :: Verbosity -> FilePath -> PackageId -> FilePath -> IO () unpackPackage verbosity prefix pkgid pkgPath = do let pkgdirname = display pkgid@@ -97,20 +119,3 @@ "A file \"" ++ pkgdir ++ "\" is in the way, not unpacking." notice verbosity $ "Unpacking to " ++ pkgdir' Tar.extractTarGzFile prefix pkgdirname pkgPath--resolvePackages :: AvailablePackageDb- -> [Dependency]- -> [Either Dependency AvailablePackage]-resolvePackages (AvailablePackageDb available prefs) deps =- map (\d -> best d (candidates d)) 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- best d [] = Left d- best _ xs = Right $ maximumBy (comparing packageId) xs-
Distribution/Client/Update.hs view
@@ -16,7 +16,7 @@ import Distribution.Client.Types ( Repo(..), RemoteRepo(..), LocalRepo(..), AvailablePackageDb(..) )-import Distribution.Client.Fetch+import Distribution.Client.FetchUtils ( downloadIndex ) import qualified Distribution.Client.PackageIndex as PackageIndex import Distribution.Client.IndexUtils@@ -35,7 +35,7 @@ import qualified Data.ByteString.Lazy as BS import qualified Data.ByteString.Lazy.Char8 as BS.Char8-import qualified Codec.Compression.GZip as GZip (decompress)+import Distribution.Client.GZipUtils (maybeDecompress) import qualified Data.Map as Map import System.FilePath (dropExtension) import Data.Maybe (fromMaybe)@@ -58,7 +58,7 @@ ++ remoteRepoName remoteRepo indexPath <- downloadIndex verbosity remoteRepo (repoLocalDir repo) writeFileAtomic (dropExtension indexPath) . BS.Char8.unpack- . GZip.decompress+ . maybeDecompress =<< BS.readFile indexPath checkForSelfUpgrade :: Verbosity -> [Repo] -> IO ()
Distribution/Client/Upload.hs view
@@ -63,27 +63,38 @@ handlePackage verbosity uploadURI auth path where targetRepoURI = remoteRepoURI $ last [ remoteRepo | Left remoteRepo <- map repoKind repos ] --FIXME: better error message when no repos are given- promptUsername :: IO Username- promptUsername = do- putStr "Hackage username: "- hFlush stdout- fmap Username getLine - promptPassword :: IO Password- promptPassword = do- putStr "Hackage password: "- hFlush stdout- -- save/restore the terminal echoing status- passwd <- bracket (hGetEcho stdin) (hSetEcho stdin) $ \_ -> do- hSetEcho stdin False -- no echoing for entering the password- fmap Password getLine- putStrLn ""- return passwd+promptUsername :: IO Username+promptUsername = do+ putStr "Hackage username: "+ hFlush stdout+ fmap Username getLine -report :: Verbosity -> [Repo] -> IO ()-report verbosity repos- = forM_ repos $ \repo ->- case repoKind repo of+promptPassword :: IO Password+promptPassword = do+ putStr "Hackage password: "+ hFlush stdout+ -- save/restore the terminal echoing status+ passwd <- bracket (hGetEcho stdin) (hSetEcho stdin) $ \_ -> do+ hSetEcho stdin False -- no echoing for entering the password+ fmap Password getLine+ putStrLn ""+ return passwd++report :: Verbosity -> [Repo] -> Maybe Username -> Maybe Password -> IO ()+report verbosity repos mUsername mPassword = do+ let uploadURI = if isOldHackageURI targetRepoURI+ then legacyUploadURI+ else targetRepoURI{uriPath = ""}+ Username username <- maybe promptUsername return mUsername+ Password password <- maybe promptPassword return mPassword+ let auth = addAuthority AuthBasic {+ auRealm = "Hackage",+ auUsername = username,+ auPassword = password,+ auSite = uploadURI+ }+ forM_ repos $ \repo -> case repoKind repo of Left remoteRepo -> do dotCabal <- defaultCabalDir let srcDir = dotCabal </> "reports" </> remoteRepoName remoteRepo@@ -95,9 +106,11 @@ Left errs -> do warn verbosity $ "Errors: " ++ errs -- FIXME Right report' -> do info verbosity $ "Uploading report for " ++ display (BuildReport.package report')- browse $ BuildReport.uploadReports (remoteRepoURI remoteRepo) [(report', Just buildLog)]+ browse $ BuildReport.uploadReports (remoteRepoURI remoteRepo) [(report', Just buildLog)] auth return () Right{} -> return ()+ where+ targetRepoURI = remoteRepoURI $ last [ remoteRepo | Left remoteRepo <- map repoKind repos ] --FIXME: better error message when no repos are given check :: Verbosity -> [FilePath] -> IO () check verbosity paths = do
+ Distribution/Client/World.hs view
@@ -0,0 +1,173 @@+-----------------------------------------------------------------------------+-- |+-- Module : Distribution.Client.World+-- Copyright : (c) Peter Robinson 2009+-- License : BSD-like+--+-- Maintainer : thaldyron@gmail.com+-- Stability : provisional+-- Portability : portable+--+-- Interface to the world-file that contains a list of explicitly+-- requested packages. Meant to be imported qualified.+--+-- A world file entry stores the package-name, package-version, and+-- user flags.+-- For example, the entry generated by+-- # cabal install stm-io-hooks --flags="-debug"+-- looks like this:+-- # stm-io-hooks -any --flags="-debug"+-- To rebuild/upgrade the packages in world (e.g. when updating the compiler)+-- use+-- # cabal install world+--+-----------------------------------------------------------------------------+module Distribution.Client.World (+ WorldPkgInfo(..),+ insert,+ delete,+ getContents,+ ) where++import Distribution.Package+ ( Dependency(..) )+import Distribution.PackageDescription+ ( FlagAssignment, FlagName(FlagName) )+import Distribution.Verbosity+ ( Verbosity )+import Distribution.Simple.Utils+ ( die, info, chattyTry, writeFileAtomic )+import Distribution.Text+ ( Text(..), display, simpleParse )+import qualified Distribution.Compat.ReadP as Parse+import qualified Text.PrettyPrint as Disp+import Text.PrettyPrint ( (<>), (<+>) )+++import Data.Char as Char++import Data.List+ ( unionBy, deleteFirstsBy, nubBy )+import Data.Maybe+ ( isJust, fromJust )+import System.IO.Error+ ( isDoesNotExistError )+import qualified Data.ByteString.Lazy.Char8 as B+import Prelude hiding (getContents)+++data WorldPkgInfo = WorldPkgInfo Dependency FlagAssignment+ deriving (Show,Eq)++-- | Adds packages to the world file; creates the file if it doesn't+-- exist yet. Version constraints and flag assignments for a package are+-- updated if already present. IO errors are non-fatal.+insert :: Verbosity -> FilePath -> [WorldPkgInfo] -> IO ()+insert = modifyWorld $ unionBy equalUDep++-- | Removes packages from the world file.+-- Note: Currently unused as there is no mechanism in Cabal (yet) to+-- handle uninstalls. IO errors are non-fatal.+delete :: Verbosity -> FilePath -> [WorldPkgInfo] -> IO ()+delete = modifyWorld $ flip (deleteFirstsBy equalUDep)++-- | WorldPkgInfo values are considered equal if they refer to+-- the same package, i.e., we don't care about differing versions or flags.+equalUDep :: WorldPkgInfo -> WorldPkgInfo -> Bool+equalUDep (WorldPkgInfo (Dependency pkg1 _) _)+ (WorldPkgInfo (Dependency pkg2 _) _) = pkg1 == pkg2++-- | Modifies the world file by applying an update-function ('unionBy'+-- for 'insert', 'deleteFirstsBy' for 'delete') to the given list of+-- packages. IO errors are considered non-fatal.+modifyWorld :: ([WorldPkgInfo] -> [WorldPkgInfo]+ -> [WorldPkgInfo])+ -- ^ Function that defines how+ -- the list of user packages are merged with+ -- existing world packages.+ -> Verbosity+ -> FilePath -- ^ Location of the world file+ -> [WorldPkgInfo] -- ^ list of user supplied packages+ -> IO ()+modifyWorld _ _ _ [] = return ()+modifyWorld f verbosity world pkgs =+ chattyTry "Error while updating world-file. " $ do+ pkgsOldWorld <- getContents world+ -- Filter out packages that are not in the world file:+ let pkgsNewWorld = nubBy equalUDep $ f pkgs pkgsOldWorld+ -- 'Dependency' is not an Ord instance, so we need to check for+ -- equivalence the awkward way:+ if not (all (`elem` pkgsOldWorld) pkgsNewWorld &&+ all (`elem` pkgsNewWorld) pkgsOldWorld)+ then do+ info verbosity "Updating world file..."+ writeFileAtomic world $ unlines+ [ (display pkg) | pkg <- pkgsNewWorld]+ else+ info verbosity "World file is already up to date."+++-- | Returns the content of the world file as a list+getContents :: FilePath -> IO [WorldPkgInfo]+getContents world = do+ content <- safelyReadFile world+ let result = map simpleParse (lines $ B.unpack content)+ if all isJust result+ then return $ map fromJust result+ else die "Could not parse world file."+ where+ safelyReadFile :: FilePath -> IO B.ByteString+ safelyReadFile file = B.readFile file `catch` handler+ where+ handler e | isDoesNotExistError e = return B.empty+ | otherwise = ioError e+++instance Text WorldPkgInfo where+ disp (WorldPkgInfo dep flags) = disp dep <+> dispFlags flags+ where+ dispFlags [] = Disp.empty+ dispFlags fs = Disp.text "--flags="+ <> Disp.doubleQuotes (flagAssToDoc fs)+ flagAssToDoc = foldr (\(FlagName fname,val) flagAssDoc ->+ (if not val then Disp.char '-'+ else Disp.empty)+ Disp.<> Disp.text fname+ Disp.<+> flagAssDoc)+ Disp.empty+ parse = do+ dep <- parse+ Parse.skipSpaces+ flagAss <- Parse.option [] parseFlagAssignment+ return $ WorldPkgInfo dep flagAss+ where+ parseFlagAssignment :: Parse.ReadP r FlagAssignment+ parseFlagAssignment = do+ _ <- Parse.string "--flags"+ Parse.skipSpaces+ _ <- Parse.char '='+ Parse.skipSpaces+ inDoubleQuotes $ Parse.many1 flag+ where+ inDoubleQuotes :: Parse.ReadP r a -> Parse.ReadP r a+ inDoubleQuotes = Parse.between (Parse.char '"') (Parse.char '"')++ flag = do+ Parse.skipSpaces+ val <- negative Parse.+++ positive+ name <- ident+ Parse.skipSpaces+ return (FlagName name,val)+ negative = do+ _ <- Parse.char '-'+ return False+ positive = return True++ ident :: Parse.ReadP r String+ ident = do+ -- First character must be a letter/digit to avoid flags+ -- like "+-debug":+ c <- Parse.satisfy Char.isAlphaNum+ cs <- Parse.munch (\ch -> Char.isAlphaNum ch || ch == '_'+ || ch == '-')+ return (c:cs)
+ Distribution/Compat/FilePerms.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE CPP #-}+-- #hide+module Distribution.Compat.FilePerms (+ setFileOrdinary,+ setFileExecutable,+ ) where++#ifndef mingw32_HOST_OS+import System.Posix.Types+ ( FileMode )+import System.Posix.Internals+ ( c_chmod )+import Foreign.C+ ( withCString )+#if MIN_VERSION_base(4,0,0)+import Foreign.C+ ( throwErrnoPathIfMinus1_ )+#else+import Foreign.C+ ( throwErrnoIfMinus1_ )+#endif+#endif /* mingw32_HOST_OS */++setFileOrdinary, setFileExecutable :: FilePath -> IO ()+#ifndef mingw32_HOST_OS+setFileOrdinary path = setFileMode path 0o644 -- file perms -rw-r--r--+setFileExecutable path = setFileMode path 0o755 -- file perms -rwxr-xr-x++setFileMode :: FilePath -> FileMode -> IO ()+setFileMode name m =+ withCString name $ \s -> do+#if __GLASGOW_HASKELL__ >= 608+ throwErrnoPathIfMinus1_ "setFileMode" name (c_chmod s m)+#else+ throwErrnoIfMinus1_ name (c_chmod s m)+#endif+#else+setFileOrdinary _ = return ()+setFileExecutable _ = return ()+#endif
Main.hs view
@@ -11,7 +11,7 @@ -- Entry point to the default cabal-install front-end. ----------------------------------------------------------------------------- -module Main where+module Main (main) where import Distribution.Client.Setup ( GlobalFlags(..), globalCommand, globalRepos@@ -19,15 +19,16 @@ , ConfigExFlags(..), configureExCommand , InstallFlags(..), defaultInstallFlags , installCommand, upgradeCommand- , fetchCommand, checkCommand+ , FetchFlags(..), fetchCommand+ , checkCommand , updateCommand , ListFlags(..), listCommand , InfoFlags(..), infoCommand , UploadFlags(..), uploadCommand+ , ReportFlags(..), reportCommand , InitFlags, initCommand , reportCommand- , unpackCommand, UnpackFlags(..)- , parsePackageArgs )+ , unpackCommand, UnpackFlags(..) ) import Distribution.Simple.Setup ( BuildFlags(..), buildCommand , HaddockFlags(..), haddockCommand@@ -39,12 +40,13 @@ , TestFlags(..), testCommand , Flag(..), fromFlag, fromFlagOrDefault, flagToMaybe ) -import Distribution.Client.Types- ( UnresolvedDependency(UnresolvedDependency) ) import Distribution.Client.SetupWrapper ( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions ) import Distribution.Client.Config ( SavedConfig(..), loadConfig, defaultConfigFile )+import Distribution.Client.Targets+ ( readUserTargets )+ import Distribution.Client.List (list, info) import Distribution.Client.Install (install, upgrade) import Distribution.Client.Configure (configure)@@ -59,8 +61,9 @@ import qualified Distribution.Client.Win32SelfUpgrade as Win32SelfUpgrade import Distribution.Simple.Compiler- ( PackageDB(..), PackageDBStack )-import Distribution.Simple.Program (defaultProgramConfiguration)+ ( Compiler, PackageDB(..), PackageDBStack )+import Distribution.Simple.Program+ ( ProgramConfiguration, defaultProgramConfiguration ) import Distribution.Simple.Command import Distribution.Simple.Configure (configCompilerAux) import Distribution.Simple.Utils@@ -68,7 +71,7 @@ import Distribution.Text ( display ) import Distribution.Verbosity as Verbosity- ( Verbosity, normal, intToVerbosity )+ ( Verbosity, normal, intToVerbosity, lessVerbose ) import qualified Paths_cabal_install (version) import System.Environment (getArgs, getProgName)@@ -112,9 +115,7 @@ putStr $ "\nYou can edit the cabal configuration file to set defaults:\n" ++ " " ++ configFile ++ "\n" printOptionsList = putStr . unlines- printErrors errs = do- putStr (concat (intersperse "\n" errs))- exitFailure+ printErrors errs = die $ concat (intersperse "\n" errs) printNumericVersion = putStrLn $ display Paths_cabal_install.version printVersion = putStrLn $ "cabal-install version " ++ display Paths_cabal_install.version@@ -127,7 +128,6 @@ ,updateCommand `commandAddAction` updateAction ,listCommand `commandAddAction` listAction ,infoCommand `commandAddAction` infoAction- ,upgradeCommand `commandAddAction` upgradeAction ,fetchCommand `commandAddAction` fetchAction ,unpackCommand `commandAddAction` unpackAction ,checkCommand `commandAddAction` checkAction@@ -150,6 +150,7 @@ regVerbosity regDistPref ,wrapperAction testCommand testVerbosity testDistPref+ ,upgradeCommand `commandAddAction` upgradeAction ] wrapperAction :: Monoid flags@@ -193,8 +194,8 @@ installAction (configFlags, configExFlags, installFlags) extraArgs globalFlags = do- pkgs <- either die return (parsePackageArgs extraArgs) let verbosity = fromFlagOrDefault normal (configVerbosity configFlags)+ targets <- readUserTargets verbosity extraArgs config <- loadConfig verbosity (globalConfigFile globalFlags) (configUserInstall configFlags) let configFlags' = savedConfigureFlags config `mappend` configFlags@@ -202,12 +203,11 @@ installFlags' = defaultInstallFlags `mappend` savedInstallFlags config `mappend` installFlags globalFlags' = savedGlobalFlags config `mappend` globalFlags- (comp, conf) <- configCompilerAux configFlags'+ (comp, conf) <- configCompilerAux' configFlags' install verbosity (configPackageDB' configFlags') (globalRepos globalFlags')- comp conf configFlags' configExFlags' installFlags'- [ UnresolvedDependency pkg (configConfigurationsFlags configFlags')- | pkg <- pkgs ]+ comp conf globalFlags' configFlags' configExFlags' installFlags'+ targets listAction :: ListFlags -> [String] -> GlobalFlags -> IO () listAction listFlags extraArgs globalFlags = do@@ -215,7 +215,7 @@ config <- loadConfig verbosity (globalConfigFile globalFlags) mempty let configFlags = savedConfigureFlags config globalFlags' = savedGlobalFlags config `mappend` globalFlags- (comp, conf) <- configCompilerAux configFlags+ (comp, conf) <- configCompilerAux' configFlags list verbosity (configPackageDB' configFlags) (globalRepos globalFlags')@@ -226,8 +226,8 @@ infoAction :: InfoFlags -> [String] -> GlobalFlags -> IO () infoAction infoFlags extraArgs globalFlags = do- pkgs <- either die return (parsePackageArgs extraArgs) let verbosity = fromFlag (infoVerbosity infoFlags)+ targets <- readUserTargets verbosity extraArgs config <- loadConfig verbosity (globalConfigFile globalFlags) mempty let configFlags = savedConfigureFlags config globalFlags' = savedGlobalFlags config `mappend` globalFlags@@ -237,8 +237,9 @@ (globalRepos globalFlags') comp conf+ globalFlags' infoFlags- [ UnresolvedDependency pkg [] | pkg <- pkgs ]+ targets updateAction :: Flag Verbosity -> [String] -> GlobalFlags -> IO () updateAction verbosityFlag extraArgs globalFlags = do@@ -253,8 +254,8 @@ -> [String] -> GlobalFlags -> IO () upgradeAction (configFlags, configExFlags, installFlags) extraArgs globalFlags = do- pkgs <- either die return (parsePackageArgs extraArgs) let verbosity = fromFlagOrDefault normal (configVerbosity configFlags)+ targets <- readUserTargets verbosity extraArgs config <- loadConfig verbosity (globalConfigFile globalFlags) (configUserInstall configFlags) let configFlags' = savedConfigureFlags config `mappend` configFlags@@ -262,26 +263,24 @@ installFlags' = defaultInstallFlags `mappend` savedInstallFlags config `mappend` installFlags globalFlags' = savedGlobalFlags config `mappend` globalFlags- (comp, conf) <- configCompilerAux configFlags'+ (comp, conf) <- configCompilerAux' configFlags' upgrade verbosity (configPackageDB' configFlags') (globalRepos globalFlags')- comp conf configFlags' configExFlags' installFlags'- [ UnresolvedDependency pkg (configConfigurationsFlags configFlags')- | pkg <- pkgs ]+ comp conf globalFlags' configFlags' configExFlags' installFlags'+ targets -fetchAction :: Flag Verbosity -> [String] -> GlobalFlags -> IO ()-fetchAction verbosityFlag extraArgs globalFlags = do- pkgs <- either die return (parsePackageArgs extraArgs)- let verbosity = fromFlag verbosityFlag+fetchAction :: FetchFlags -> [String] -> GlobalFlags -> IO ()+fetchAction fetchFlags extraArgs globalFlags = do+ let verbosity = fromFlag (fetchVerbosity fetchFlags)+ targets <- readUserTargets verbosity extraArgs config <- loadConfig verbosity (globalConfigFile globalFlags) mempty let configFlags = savedConfigureFlags config globalFlags' = savedGlobalFlags config `mappend` globalFlags- (comp, conf) <- configCompilerAux configFlags+ (comp, conf) <- configCompilerAux' configFlags fetch verbosity (configPackageDB' configFlags) (globalRepos globalFlags')- comp conf- [ UnresolvedDependency pkg [] --TODO: flags?- | pkg <- pkgs ]+ comp conf globalFlags' fetchFlags+ targets uploadAction :: UploadFlags -> [String] -> GlobalFlags -> IO () uploadAction uploadFlags extraArgs globalFlags = do@@ -329,28 +328,38 @@ die $ "'sdist' doesn't take any extra arguments: " ++ unwords extraArgs sdist sflags -reportAction :: Flag Verbosity -> [String] -> GlobalFlags -> IO ()-reportAction verbosityFlag extraArgs globalFlags = do+reportAction :: ReportFlags -> [String] -> GlobalFlags -> IO ()+reportAction reportFlags extraArgs globalFlags = do unless (null extraArgs) $ do die $ "'report' doesn't take any extra arguments: " ++ unwords extraArgs - let verbosity = fromFlag verbosityFlag+ let verbosity = fromFlag (reportVerbosity reportFlags) config <- loadConfig verbosity (globalConfigFile globalFlags) mempty let globalFlags' = savedGlobalFlags config `mappend` globalFlags+ reportFlags' = savedReportFlags config `mappend` reportFlags Upload.report verbosity (globalRepos globalFlags')+ (flagToMaybe $ reportUsername reportFlags')+ (flagToMaybe $ reportPassword reportFlags') unpackAction :: UnpackFlags -> [String] -> GlobalFlags -> IO ()-unpackAction flags extraArgs globalFlags = do- pkgs <- either die return (parsePackageArgs extraArgs)- let verbosity = fromFlag (unpackVerbosity flags)+unpackAction unpackFlags extraArgs globalFlags = do+ let verbosity = fromFlag (unpackVerbosity unpackFlags)+ targets <- readUserTargets verbosity extraArgs config <- loadConfig verbosity (globalConfigFile globalFlags) mempty- unpack flags (globalRepos (savedGlobalFlags config)) pkgs+ let globalFlags' = savedGlobalFlags config `mappend` globalFlags+ unpack verbosity+ (globalRepos (savedGlobalFlags config))+ globalFlags'+ unpackFlags+ targets initAction :: InitFlags -> [String] -> GlobalFlags -> IO () initAction flags _extraArgs _globalFlags = do initCabal flags +-- | See 'Distribution.Client.Install.withWin32SelfUpgrade' for details.+-- win32SelfUpgradeAction :: [String] -> IO () win32SelfUpgradeAction (pid:path:rest) = Win32SelfUpgrade.deleteOldExeFile verbosity (read pid) path@@ -385,3 +394,10 @@ implicitPackageDbStack userInstall (flagToMaybe (configPackageDB cfg)) where userInstall = fromFlagOrDefault True (configUserInstall cfg)++configCompilerAux' :: ConfigFlags+ -> IO (Compiler, ProgramConfiguration)+configCompilerAux' configFlags =+ configCompilerAux configFlags+ --FIXME: make configCompilerAux use a sensible verbosity+ { configVerbosity = fmap lessVerbose (configVerbosity configFlags) }
README view
@@ -19,7 +19,7 @@ It requires a few other Haskell packages that are not always installed: - * Cabal (version 1.8 or later)+ * Cabal (version 1.10 or later) * HTTP (version 4000 or later) * zlib (version 0.4 or later)
bash-completion/cabal view
@@ -3,70 +3,6 @@ # "Duncan Coutts" <dcoutts@gentoo.org> # -# returns packages from cabal list-# usage: _cabal_packages [packages] [versions] [installed]-_cabal_packages()-{- local packages=no # print package names with versions? ie. foo- local versions=no # print packages and versions? ie. foo-0.42- local installed=no # only print installed packages?-- while [[ -n "$1" ]]; do- case "$1" in- packages)- packages=yes ;;- versions)- versions=yes ;;- installed)- installed=yes ;;- esac- shift- done-- if [[ "$packages" == "no" && "$versions" == "no" ]]; then- # nothing to print- # set sensible default, print only packages- packages=yes- fi-- local cmd="cabal list --simple-output"- if [[ "$installed" == "yes" ]]; then- cmd="$cmd --installed"- fi-- # save 'cabal list' output to a temporary file- # putting it in a variable would mess up the lines- local tmp=$( mktemp /tmp/cabal_completion.XXXXXX )- $cmd > $tmp-- if [[ "$packages" == "yes" ]]; then- # print only the names- cat "$tmp" | cut -d' ' -f1 | uniq- fi-- if [[ "$versions" == "yes" ]]; then- # join the name and the version with a dash- cat "$tmp" | sed -e "s: :-:"- fi-- rm -f "$tmp"-}--_cabal_commands()-{- # this is already quite fast, and caching does not give a speedup- # 3-4ms- for word in $( cabal --list-options ); do- case $word in- -*)- # ignore flags- continue;;- *)- echo $word ;;- esac- done-}- _cabal() { # get the word currently being completed@@ -78,54 +14,11 @@ # copy all words the user has entered cmd=( ${COMP_WORDS[@]} ) - # the word currently beeing completed- local ccword- ccword=cmd[${COMP_CWORD}]- # replace the current word with --list-options cmd[${COMP_CWORD}]="--list-options" - # find the action being completed- local action="unknown"- for cword in ${COMP_WORDS[*]}; do- for act in $( _cabal_commands ); do- if [[ "$cword" == "$act" ]]; then- action=$act- fi- done- done-- # if non empty, we will pass this to _cabal_packages and add the result- # to the completing words- local complete_packages- for cword in ${COMP_WORDS[*]}; do- case $cword in- --installed)- # the user is interested only in installed packages- complete_packages="$complete_packages installed"- esac- done-- case $action in- install|list|upgrade|fetch)- if [[ "$cword" != -* ]]; then- # don't complete with packages if the user is trying to- # complete a flag- complete_packages="$complete_packages packages"- if [[ "$cword" == *- ]]; then- # if the user tries to complete with a version, help by- # completing them too- complete_packages="$complete_packages versions"- fi- fi ;;- esac- # the resulting completions should be put into this array COMPREPLY=( $( compgen -W "$( ${cmd[@]} )" -- $cur ) )-- if [[ -n "$complete_packages" ]]; then- COMPREPLY+=( $( compgen -W "$( _cabal_packages $complete_packages )" -- $cur ) )- fi } complete -F _cabal -o default cabal
bootstrap.sh view
@@ -16,6 +16,7 @@ GHC_PKG=${GHC_PKG:-ghc-pkg} WGET=${WGET:-wget} CURL=${CURL:-curl}+FETCH=${FETCH:-fetch} TAR=${TAR:-tar} GUNZIP=${GUNZIP:-gunzip} SCOPE_OF_INSTALLATION="--user"@@ -37,7 +38,7 @@ echo echo "options:" echo " --user Install for the local user (default)"- echo " --global Install systemwide"+ echo " --global Install systemwide (must be run as root)" exit;; esac done@@ -45,12 +46,14 @@ # Versions of the packages to install. # The version regex says what existing installed versions are ok.-PARSEC_VER="2.1.0.1"; PARSEC_VER_REGEXP="2\." # == 2.*-NETWORK_VER="2.2.1.5"; NETWORK_VER_REGEXP="2\." # == 2.*-CABAL_VER="1.8.0.2"; CABAL_VER_REGEXP="1\.8\." # == 1.8.*-MTL_VER="1.1.0.2"; MTL_VER_REGEXP="1\.1\." # == 1.1.*-HTTP_VER="4000.0.8"; HTTP_VER_REGEXP="4000\.0" # == 4000.0.*-ZLIB_VER="0.5.2.0"; ZLIB_VER_REGEXP="0\.[45]\." # == 0.5.*+PARSEC_VER="3.1.1"; PARSEC_VER_REGEXP="[23]\." # == 2.* || == 3.*+NETWORK_VER="2.3.0.2"; NETWORK_VER_REGEXP="2\." # == 2.*+CABAL_VER="1.10.1.0"; CABAL_VER_REGEXP="1\.10\.[^0]" # == 1.10.* && >= 1.10.1+TRANS_VER="0.2.2.0"; TRANS_VER_REGEXP="0\.2\." # == 0.2.*+MTL_VER="2.0.1.0"; MTL_VER_REGEXP="[12]\." # == 1.* || == 2.*+HTTP_VER="4000.1.1"; HTTP_VER_REGEXP="4000\.[01]\." # == 4000.0.* || 4000.1.*+ZLIB_VER="0.5.3.1"; ZLIB_VER_REGEXP="0\.[45]\." # == 0.4.* || ==0.5.*+TIME_VER="1.2.0.4" TIME_VER_REGEXP="1\.[12]\." # == 0.1.* || ==0.2.* HACKAGE_URL="http://hackage.haskell.org/packages/archive" @@ -76,7 +79,7 @@ # Cache the list of packages: echo "Checking installed packages for ghc-${GHC_VER}..."-${GHC_PKG} list > ghc-pkg.list \+${GHC_PKG} list --global ${SCOPE_OF_INSTALLATION} > ghc-pkg.list \ || die "running '${GHC_PKG} list' failed" # Will we need to install this package, or is a suitable version installed?@@ -105,23 +108,6 @@ fi } -dep_pkg () {- PKG=$1- VER_MATCH=$2- if need_pkg ${PKG} ${VER_MATCH}- then- echo- echo "The Haskell package '${PKG}' is required but it is not installed."- echo "If you are using a ghc package provided by your operating system"- echo "then install the corresponding packages for 'parsec' and 'network'."- echo "If you built ghc from source with only the core libraries then you"- echo "should install these extra packages. You can get them from hackage."- die "The Haskell package '${PKG}' is required but it is not installed."- else- echo "${PKG} is already installed and the version is ok."- fi-}- fetch_pkg () { PKG=$1 VER=$2@@ -129,12 +115,15 @@ URL=${HACKAGE_URL}/${PKG}/${VER}/${PKG}-${VER}.tar.gz if which ${CURL} > /dev/null then- ${CURL} -C - -O ${URL} || die "Failed to download ${PKG}."+ ${CURL} --fail -C - -O ${URL} || die "Failed to download ${PKG}." elif which ${WGET} > /dev/null then ${WGET} -c ${URL} || die "Failed to download ${PKG}."+ elif which ${FETCH} > /dev/null+ then+ ${FETCH} ${URL} || die "Failed to download ${PKG}." else- die "Failed to find a downloader. 'wget' or 'curl' is required."+ die "Failed to find a downloader. 'curl', 'wget' or 'fetch' is required." fi [ -f "${PKG}-${VER}.tar.gz" ] \ || die "Downloading ${URL} did not create ${PKG}-${VER}.tar.gz"@@ -194,19 +183,23 @@ # Actually do something! -info_pkg "parsec" ${PARSEC_VER} ${PARSEC_VER_REGEXP}-info_pkg "network" ${NETWORK_VER} ${NETWORK_VER_REGEXP}-info_pkg "Cabal" ${CABAL_VER} ${CABAL_VER_REGEXP}-info_pkg "mtl" ${MTL_VER} ${MTL_VER_REGEXP}-info_pkg "HTTP" ${HTTP_VER} ${HTTP_VER_REGEXP}-info_pkg "zlib" ${ZLIB_VER} ${ZLIB_VER_REGEXP}+info_pkg "Cabal" ${CABAL_VER} ${CABAL_VER_REGEXP}+info_pkg "transformers" ${TRANS_VER} ${TRANS_VER_REGEXP}+info_pkg "mtl" ${MTL_VER} ${MTL_VER_REGEXP}+info_pkg "parsec" ${PARSEC_VER} ${PARSEC_VER_REGEXP}+info_pkg "network" ${NETWORK_VER} ${NETWORK_VER_REGEXP}+info_pkg "time" ${TIME_VER} ${TIME_VER_REGEXP}+info_pkg "HTTP" ${HTTP_VER} ${HTTP_VER_REGEXP}+info_pkg "zlib" ${ZLIB_VER} ${ZLIB_VER_REGEXP} -do_pkg "parsec" ${PARSEC_VER} ${PARSEC_VER_REGEXP}-do_pkg "network" ${NETWORK_VER} ${NETWORK_VER_REGEXP}-do_pkg "Cabal" ${CABAL_VER} ${CABAL_VER_REGEXP}-do_pkg "mtl" ${MTL_VER} ${MTL_VER_REGEXP}-do_pkg "HTTP" ${HTTP_VER} ${HTTP_VER_REGEXP}-do_pkg "zlib" ${ZLIB_VER} ${ZLIB_VER_REGEXP}+do_pkg "Cabal" ${CABAL_VER} ${CABAL_VER_REGEXP}+do_pkg "transformers" ${TRANS_VER} ${TRANS_VER_REGEXP}+do_pkg "mtl" ${MTL_VER} ${MTL_VER_REGEXP}+do_pkg "parsec" ${PARSEC_VER} ${PARSEC_VER_REGEXP}+do_pkg "network" ${NETWORK_VER} ${NETWORK_VER_REGEXP}+do_pkg "time" ${TIME_VER} ${TIME_VER_REGEXP}+do_pkg "HTTP" ${HTTP_VER} ${HTTP_VER_REGEXP}+do_pkg "zlib" ${ZLIB_VER} ${ZLIB_VER_REGEXP} install_pkg "cabal-install"
cabal-install.cabal view
@@ -1,5 +1,5 @@ Name: cabal-install-Version: 0.8.2+Version: 0.10.0 Synopsis: The command-line interface for Cabal and Hackage. Description: The \'cabal\' command-line program simplifies the process of managing@@ -13,18 +13,17 @@ Paolo Martini <paolo@nemail.it> Bjorn Bringert <bjorn@bringert.net> Isaac Potoczny-Jones <ijones@syntaxpolice.org>- Duncan Coutts <duncan@haskell.org>+ Duncan Coutts <duncan@community.haskell.org> Maintainer: cabal-devel@haskell.org Copyright: 2005 Lemmih <lemmih@gmail.com> 2006 Paolo Martini <paolo@nemail.it> 2007 Bjorn Bringert <bjorn@bringert.net> 2007 Isaac Potoczny-Jones <ijones@syntaxpolice.org>- 2008-2009 Duncan Coutts <duncan@haskell.org>+ 2007-2011 Duncan Coutts <duncan@community.haskell.org> Category: Distribution Build-type: Simple Extra-Source-Files: README bash-completion/cabal bootstrap.sh Cabal-Version: >= 1.6-Tested-With: GHC==6.6.1, GHC==6.8.2, GHC==6.10.4, GHC==6.12.1 source-repository head type: darcs@@ -32,8 +31,8 @@ source-repository this type: darcs- location: http://darcs.haskell.org/cabal-branches/cabal-install-0.8/- tag: 0.8.2+ location: http://darcs.haskell.org/cabal-branches/cabal-install-0.10/+ tag: 0.10.0 flag old-base description: Old, monolithic base@@ -57,12 +56,13 @@ Distribution.Client.Config Distribution.Client.Configure Distribution.Client.Dependency- Distribution.Client.Dependency.Bogus Distribution.Client.Dependency.TopDown Distribution.Client.Dependency.TopDown.Constraints Distribution.Client.Dependency.TopDown.Types Distribution.Client.Dependency.Types Distribution.Client.Fetch+ Distribution.Client.FetchUtils+ Distribution.Client.GZipUtils Distribution.Client.Haddock Distribution.Client.HttpUtils Distribution.Client.IndexUtils@@ -80,32 +80,35 @@ Distribution.Client.SetupWrapper Distribution.Client.SrcDist Distribution.Client.Tar+ Distribution.Client.Targets Distribution.Client.Types Distribution.Client.Unpack Distribution.Client.Update Distribution.Client.Upload Distribution.Client.Utils+ Distribution.Client.World Distribution.Client.Win32SelfUpgrade Distribution.Compat.Exception+ Distribution.Compat.FilePerms Paths_cabal_install build-depends: base >= 2 && < 5,- Cabal >= 1.8 && < 1.9,- filepath >= 1.0,+ Cabal >= 1.10.1 && < 1.11,+ filepath >= 1.0 && < 1.3, network >= 1 && < 3, HTTP >= 4000.0.2 && < 4001, zlib >= 0.4 && < 0.6,- time >= 1.1 && < 1.2+ time >= 1.1 && < 1.3 if flag(old-base) build-depends: base < 3 else build-depends: base >= 3, process >= 1 && < 1.1,- directory >= 1 && < 1.1,+ directory >= 1 && < 1.2, pretty >= 1 && < 1.1, random >= 1 && < 1.1,- containers >= 0.1 && < 0.4,+ containers >= 0.1 && < 0.5, array >= 0.1 && < 0.4, old-time >= 1 && < 1.1