diff --git a/Distribution/Client/BuildReports/Storage.hs b/Distribution/Client/BuildReports/Storage.hs --- a/Distribution/Client/BuildReports/Storage.hs +++ b/Distribution/Client/BuildReports/Storage.hs @@ -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 diff --git a/Distribution/Client/BuildReports/Upload.hs b/Distribution/Client/BuildReports/Upload.hs --- a/Distribution/Client/BuildReports/Upload.hs +++ b/Distribution/Client/BuildReports/Upload.hs @@ -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)), diff --git a/Distribution/Client/Config.hs b/Distribution/Client/Config.hs --- a/Distribution/Client/Config.hs +++ b/Distribution/Client/Config.hs @@ -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" diff --git a/Distribution/Client/Configure.hs b/Distribution/Client/Configure.hs --- a/Distribution/Client/Configure.hs +++ b/Distribution/Client/Configure.hs @@ -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 diff --git a/Distribution/Client/Dependency.hs b/Distribution/Client/Dependency.hs --- a/Distribution/Client/Dependency.hs +++ b/Distribution/Client/Dependency.hs @@ -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) diff --git a/Distribution/Client/Dependency/Bogus.hs b/Distribution/Client/Dependency/Bogus.hs deleted file mode 100644 --- a/Distribution/Client/Dependency/Bogus.hs +++ /dev/null @@ -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 diff --git a/Distribution/Client/Dependency/TopDown.hs b/Distribution/Client/Dependency/TopDown.hs --- a/Distribution/Client/Dependency/TopDown.hs +++ b/Distribution/Client/Dependency/TopDown.hs @@ -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 diff --git a/Distribution/Client/Dependency/TopDown/Constraints.hs b/Distribution/Client/Dependency/TopDown/Constraints.hs --- a/Distribution/Client/Dependency/TopDown/Constraints.hs +++ b/Distribution/Client/Dependency/TopDown/Constraints.hs @@ -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 -- diff --git a/Distribution/Client/Dependency/Types.hs b/Distribution/Client/Dependency/Types.hs --- a/Distribution/Client/Dependency/Types.hs +++ b/Distribution/Client/Dependency/Types.hs @@ -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 diff --git a/Distribution/Client/Fetch.hs b/Distribution/Client/Fetch.hs --- a/Distribution/Client/Fetch.hs +++ b/Distribution/Client/Fetch.hs @@ -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 () diff --git a/Distribution/Client/FetchUtils.hs b/Distribution/Client/FetchUtils.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/FetchUtils.hs @@ -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"] + } diff --git a/Distribution/Client/GZipUtils.hs b/Distribution/Client/GZipUtils.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/GZipUtils.hs @@ -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: +-- +-- +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 diff --git a/Distribution/Client/Haddock.hs b/Distribution/Client/Haddock.hs --- a/Distribution/Client/Haddock.hs +++ b/Distribution/Client/Haddock.hs @@ -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 diff --git a/Distribution/Client/IndexUtils.hs b/Distribution/Client/IndexUtils.hs --- a/Distribution/Client/IndexUtils.hs +++ b/Distribution/Client/IndexUtils.hs @@ -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 ] diff --git a/Distribution/Client/Init/Heuristics.hs b/Distribution/Client/Init/Heuristics.hs --- a/Distribution/Client/Init/Heuristics.hs +++ b/Distribution/Client/Init/Heuristics.hs @@ -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)] diff --git a/Distribution/Client/Install.hs b/Distribution/Client/Install.hs --- a/Distribution/Client/Install.hs +++ b/Distribution/Client/Install.hs @@ -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 diff --git a/Distribution/Client/InstallPlan.hs b/Distribution/Client/InstallPlan.hs --- a/Distribution/Client/InstallPlan.hs +++ b/Distribution/Client/InstallPlan.hs @@ -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. diff --git a/Distribution/Client/List.hs b/Distribution/Client/List.hs --- a/Distribution/Client/List.hs +++ b/Distribution/Client/List.hs @@ -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) diff --git a/Distribution/Client/PackageIndex.hs b/Distribution/Client/PackageIndex.hs --- a/Distribution/Client/PackageIndex.hs +++ b/Distribution/Client/PackageIndex.hs @@ -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 diff --git a/Distribution/Client/Setup.hs b/Distribution/Client/Setup.hs --- a/Distribution/Client/Setup.hs +++ b/Distribution/Client/Setup.hs @@ -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 diff --git a/Distribution/Client/SetupWrapper.hs b/Distribution/Client/SetupWrapper.hs --- a/Distribution/Client/SetupWrapper.hs +++ b/Distribution/Client/SetupWrapper.hs @@ -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) diff --git a/Distribution/Client/Tar.hs b/Distribution/Client/Tar.hs --- a/Distribution/Client/Tar.hs +++ b/Distribution/Client/Tar.hs @@ -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 diff --git a/Distribution/Client/Targets.hs b/Distribution/Client/Targets.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/Targets.hs @@ -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 ] diff --git a/Distribution/Client/Types.hs b/Distribution/Client/Types.hs --- a/Distribution/Client/Types.hs +++ b/Distribution/Client/Types.hs @@ -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 diff --git a/Distribution/Client/Unpack.hs b/Distribution/Client/Unpack.hs --- a/Distribution/Client/Unpack.hs +++ b/Distribution/Client/Unpack.hs @@ -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 - diff --git a/Distribution/Client/Update.hs b/Distribution/Client/Update.hs --- a/Distribution/Client/Update.hs +++ b/Distribution/Client/Update.hs @@ -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 () diff --git a/Distribution/Client/Upload.hs b/Distribution/Client/Upload.hs --- a/Distribution/Client/Upload.hs +++ b/Distribution/Client/Upload.hs @@ -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 diff --git a/Distribution/Client/World.hs b/Distribution/Client/World.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/World.hs @@ -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) diff --git a/Distribution/Compat/FilePerms.hs b/Distribution/Compat/FilePerms.hs new file mode 100644 --- /dev/null +++ b/Distribution/Compat/FilePerms.hs @@ -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 diff --git a/Main.hs b/Main.hs --- a/Main.hs +++ b/Main.hs @@ -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) } diff --git a/README b/README --- a/README +++ b/README @@ -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) diff --git a/bash-completion/cabal b/bash-completion/cabal --- a/bash-completion/cabal +++ b/bash-completion/cabal @@ -3,70 +3,6 @@ # "Duncan Coutts" # -# 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 diff --git a/bootstrap.sh b/bootstrap.sh --- a/bootstrap.sh +++ b/bootstrap.sh @@ -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" diff --git a/cabal-install.cabal b/cabal-install.cabal --- a/cabal-install.cabal +++ b/cabal-install.cabal @@ -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 Bjorn Bringert Isaac Potoczny-Jones - Duncan Coutts + Duncan Coutts Maintainer: cabal-devel@haskell.org Copyright: 2005 Lemmih 2006 Paolo Martini 2007 Bjorn Bringert 2007 Isaac Potoczny-Jones - 2008-2009 Duncan Coutts + 2007-2011 Duncan Coutts 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