cabal-install 0.6.0 → 0.6.2

raw patch · 31 files changed

+2027/−700 lines, 31 filesdep ~HTTPdep ~base

Dependency ranges changed: HTTP, base

Files

Distribution/Client/BuildReports/Storage.hs +33/−21
Distribution/Client/BuildReports/Types.hs +44/−0
Distribution/Client/BuildReports/Upload.hs +7/−3
Distribution/Client/Config.hs +69/−19
Distribution/Client/Configure.hs +210/−0
Distribution/Client/Dependency.hs +86/−61
Distribution/Client/Dependency/Bogus.hs +47/−25
Distribution/Client/Dependency/TopDown.hs +155/−71
Distribution/Client/Dependency/TopDown/Constraints.hs +66/−21
Distribution/Client/Dependency/Types.hs +24/−20
Distribution/Client/Fetch.hs +23/−12
Distribution/Client/HttpUtils.hs +25/−11
Distribution/Client/IndexUtils.hs +25/−1
Distribution/Client/Install.hs +192/−120
Distribution/Client/InstallPlan.hs +18/−21
Distribution/Client/InstallSymlink.hs +3/−2
Distribution/Client/List.hs +259/−75
Distribution/Client/Setup.hs +209/−61
Distribution/Client/SetupWrapper.hs +10/−3
Distribution/Client/SrcDist.hs +7/−10
Distribution/Client/Tar.hs +23/−15
Distribution/Client/Unpack.hs +98/−0
Distribution/Client/Update.hs +36/−6
Distribution/Client/Upload.hs +14/−9
Distribution/Client/Utils.hs +11/−2
Distribution/Client/Win32SelfUpgrade.hs +0/−3
Distribution/Compat/TempFile.hs +28/−0
Main.hs +106/−59
README +10/−7
bootstrap.sh +175/−37
cabal-install.cabal +14/−5

Distribution/Client/BuildReports/Storage.hs view

@@ -31,11 +31,12 @@ import qualified Distribution.Client.InstallPlan as InstallPlan import Distribution.Client.InstallPlan          ( InstallPlan, PlanPackage )-import Distribution.Client.Config-         ( defaultLogsDir ) +import Distribution.Simple.InstallDirs+         ( PathTemplate, fromPathTemplate+         , initialPathTemplateEnv, substPathTemplate ) import Distribution.System-         ( OS, Arch )+         ( Platform(Platform) ) import Distribution.Compiler          ( CompilerId ) import Distribution.Simple.Utils@@ -46,7 +47,7 @@ import Data.Maybe          ( catMaybes ) import System.FilePath-         ( (</>) )+         ( (</>), takeDirectory ) import System.Directory          ( createDirectoryIfMissing ) @@ -75,43 +76,54 @@       [ (report, repo, remoteRepo)       | (report, repo@Repo { repoKind = Left remoteRepo }) <- rs ] -storeLocal :: [(BuildReport, Repo)] -> IO ()-storeLocal reports = do-  logsDir <- defaultLogsDir-  let file = logsDir </> "build.log"-  createDirectoryIfMissing True logsDir-  appendFile file (concatMap (format . fst) reports)-  --TODO: make this concurrency safe, either lock the report file or make sure-  -- the writes for each report are atomic (under 4k and flush at boundaries)-+storeLocal :: [PathTemplate] -> [(BuildReport, Repo)] -> IO ()+storeLocal templates reports = sequence_+  [ do createDirectoryIfMissing True (takeDirectory file)+       appendFile file output+       --TODO: make this concurrency safe, either lock the report file or make+       --      sure the writes for each report are atomic+  | (file, reports') <- groupByFileName+                          [ (reportFileName template report, report)+                          | template <- templates+                          , (report, _repo) <- reports ]+  , let output = concatMap format reports'+  ]   where     format r = '\n' : BuildReport.show r ++ "\n" +    reportFileName template report =+        fromPathTemplate (substPathTemplate env template)+      where env = initialPathTemplateEnv+                    (BuildReport.package  report)+                    (BuildReport.compiler report) +    groupByFileName = map (\grp@((filename,_):_) -> (filename, map snd grp))+                    . groupBy (equating  fst)+                    . sortBy  (comparing fst)+ -- ------------------------------------------------------------ -- * InstallPlan support -- ------------------------------------------------------------  fromInstallPlan :: InstallPlan -> [(BuildReport, Repo)] fromInstallPlan plan = catMaybes-                     . map (fromPlanPackage os' arch' comp)+                     . map (fromPlanPackage platform comp)                      . InstallPlan.toList                      $ plan-  where os'   = InstallPlan.planOS plan-        arch' = InstallPlan.planArch plan-        comp  = InstallPlan.planCompiler plan+  where platform = InstallPlan.planPlatform plan+        comp     = InstallPlan.planCompiler plan -fromPlanPackage :: OS -> Arch -> CompilerId+fromPlanPackage :: Platform -> CompilerId                 -> InstallPlan.PlanPackage                 -> Maybe (BuildReport, Repo)-fromPlanPackage os' arch' comp planPackage = case planPackage of+fromPlanPackage (Platform arch os) comp planPackage = case planPackage of    InstallPlan.Installed pkg@(ConfiguredPackage (AvailablePackage {                           packageSource = RepoTarballPackage repo }) _ _) result-    -> Just $ (BuildReport.new os' arch' comp pkg (Right result), repo)+    -> Just $ (BuildReport.new os arch comp pkg (Right result), repo)    InstallPlan.Failed pkg@(ConfiguredPackage (AvailablePackage {                        packageSource = RepoTarballPackage repo }) _ _) result-    -> Just $ (BuildReport.new os' arch' comp pkg (Left result), repo)+    -> Just $ (BuildReport.new os arch comp pkg (Left result), repo)    _ -> Nothing

+ Distribution/Client/BuildReports/Types.hs view

@@ -0,0 +1,44 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.BuildReports.Types+-- Copyright   :  (c) Duncan Coutts 2009+-- License     :  BSD-like+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- Types related to build reporting+--+-----------------------------------------------------------------------------+module Distribution.Client.BuildReports.Types (+    ReportLevel(..),+  ) where++import qualified Distribution.Text as Text+         ( Text(disp, parse) )++import qualified Distribution.Compat.ReadP as Parse+         ( pfail, munch1 )+import qualified Text.PrettyPrint.HughesPJ as Disp+         ( text )++import Data.Char as Char+         ( isAlpha, toLower )++data ReportLevel = NoReports | AnonymousReports | DetailedReports+  deriving (Eq, Ord, Show)++instance Text.Text ReportLevel where+  disp NoReports        = Disp.text "none"+  disp AnonymousReports = Disp.text "anonymous"+  disp DetailedReports  = Disp.text "detailed"+  parse = do+    name <- Parse.munch1 Char.isAlpha+    case lowercase name of+      "none"       -> return NoReports+      "anonymous"  -> return AnonymousReports+      "detailed"   -> return DetailedReports+      _            -> Parse.pfail++lowercase :: String -> String+lowercase = map Char.toLower

Distribution/Client/BuildReports/Upload.hs view

@@ -14,6 +14,7 @@ import Network.HTTP          ( Header(..), HeaderName(..)          , Request(..), RequestMethod(..), Response(..) )+import Network.TCP (HandleStream) import Network.URI (URI, uriPath, parseRelativeReference, relativeTo)  import Control.Monad@@ -26,7 +27,8 @@ type BuildReportId = URI type BuildLog = String -uploadReports :: URI -> [(BuildReport, Maybe BuildLog)] ->  BrowserAction ()+uploadReports :: URI -> [(BuildReport, Maybe BuildLog)]+              ->  BrowserAction (HandleStream BuildLog) () uploadReports uri reports     = forM_ reports $ \(report, mbBuildLog) ->       do buildId <- postBuildReport uri report@@ -34,7 +36,8 @@            Just buildLog -> putBuildLog buildId buildLog            Nothing       -> return () -postBuildReport :: URI -> BuildReport -> BrowserAction BuildReportId+postBuildReport :: URI -> BuildReport+                -> BrowserAction (HandleStream BuildLog) BuildReportId postBuildReport uri buildReport = do   setAllowRedirects False   (_, response) <- request Request {@@ -53,7 +56,8 @@     _         -> error "Unrecognised response from server."   where body  = BuildReport.show buildReport -putBuildLog :: BuildReportId -> BuildLog -> BrowserAction ()+putBuildLog :: BuildReportId -> BuildLog+            -> BrowserAction (HandleStream BuildLog) () putBuildLog reportId buildLog = do   --FIXME: do something if the request fails   (_, response) <- request Request {

Distribution/Client/Config.hs view

@@ -19,6 +19,7 @@     parseConfig,      defaultCabalDir,+    defaultConfigFile,     defaultCacheDir,     defaultLogsDir,   ) where@@ -26,8 +27,11 @@  import Distribution.Client.Types          ( RemoteRepo(..), Username(..), Password(..) )+import Distribution.Client.BuildReports.Types+         ( ReportLevel(..) ) import Distribution.Client.Setup          ( GlobalFlags(..), globalCommand+         , ConfigExFlags(..), configureExOptions, defaultConfigExFlags          , InstallFlags(..), installOptions, defaultInstallFlags          , UploadFlags(..), uploadCommand          , showRepo, parseRepo )@@ -42,11 +46,13 @@          ( FieldDescr(..), liftField          , ParseResult(..), locatedErrorMsg, showPWarning          , readFields, warning, lineNo-         , simpleField, listField, parseFilePathQ, parseTokenQ )+         , simpleField, listField, parseFilePathQ, showFilePath, parseTokenQ ) import qualified Distribution.ParseUtils as ParseUtils          ( Field(..) )+import qualified Distribution.Text as Text+         ( Text(..) ) import Distribution.ReadE-         ( succeedReadE )+         ( readP_to_E ) import Distribution.Simple.Command          ( CommandUI(commandOptions), commandDefaultFlags, ShowOrParseArgs(..)          , viewAsFieldDescr, OptionField, option, reqArg )@@ -62,7 +68,7 @@          ( Verbosity, normal )  import Data.List-         ( partition )+         ( partition, find ) import Data.Maybe          ( fromMaybe ) import Data.Monoid@@ -73,7 +79,7 @@ import qualified Distribution.Compat.ReadP as Parse          ( option ) import qualified Text.PrettyPrint.HughesPJ as Disp-         ( Doc, render, text, colon, vcat, isEmpty, nest )+         ( Doc, render, text, colon, vcat, empty, isEmpty, nest ) import Text.PrettyPrint.HughesPJ          ( (<>), (<+>), ($$), ($+$) ) import System.Directory@@ -93,6 +99,7 @@     savedGlobalFlags       :: GlobalFlags,     savedInstallFlags      :: InstallFlags,     savedConfigureFlags    :: ConfigFlags,+    savedConfigureExFlags  :: ConfigExFlags,     savedUserInstallDirs   :: InstallDirs (Flag PathTemplate),     savedGlobalInstallDirs :: InstallDirs (Flag PathTemplate),     savedUploadFlags       :: UploadFlags@@ -103,6 +110,7 @@     savedGlobalFlags       = mempty,     savedInstallFlags      = mempty,     savedConfigureFlags    = mempty,+    savedConfigureExFlags  = mempty,     savedUserInstallDirs   = mempty,     savedGlobalInstallDirs = mempty,     savedUploadFlags       = mempty@@ -111,6 +119,7 @@     savedGlobalFlags       = combine savedGlobalFlags,     savedInstallFlags      = combine savedInstallFlags,     savedConfigureFlags    = combine savedConfigureFlags,+    savedConfigureExFlags  = combine savedConfigureExFlags,     savedUserInstallDirs   = combine savedUserInstallDirs,     savedGlobalInstallDirs = combine savedGlobalInstallDirs,     savedUploadFlags       = combine savedUploadFlags@@ -167,10 +176,15 @@ initialSavedConfig :: IO SavedConfig initialSavedConfig = do   cacheDir   <- defaultCacheDir+  logsDir    <- defaultLogsDir   return mempty {     savedGlobalFlags     = mempty {       globalCacheDir     = toFlag cacheDir,       globalRemoteRepos  = [defaultRemoteRepo]+    },+    savedInstallFlags    = mempty {+      installSummaryFile = [toPathTemplate (logsDir </> "build.log")],+      installBuildReports= toFlag AnonymousReports     }   } @@ -233,7 +247,7 @@       let (line, msg) = locatedErrorMsg err       warn verbosity $           "Error parsing config file " ++ configFile-        ++ maybe "" (\n -> ":" ++ show n) line ++ ": " ++ show msg+        ++ maybe "" (\n -> ":" ++ show n) line ++ ":\n" ++ msg       warn verbosity $ "Using default configuration."       initialSavedConfig @@ -256,7 +270,19 @@ writeConfigFile :: FilePath -> SavedConfig -> SavedConfig -> IO () writeConfigFile file comments vals = do   createDirectoryIfMissing True (takeDirectory file)-  writeFile file $ showConfigWithComments comments vals ++ "\n"+  writeFile file $ explanation ++ showConfigWithComments comments vals ++ "\n"+  where+    explanation = unlines+      ["-- This is the configuration file for the 'cabal' command line tool."+      ,""+      ,"-- The available configuration options are listed below."+      ,"-- Some of them have default values listed."+      ,""+      ,"-- Lines (like this one) beginning with '--' are comments."+      ,"-- Be careful with spaces and indentation because they are"+      ,"-- used to indicate layout for nested sections."+      ,"",""+      ]  -- | These are the default values that get used in Cabal if a no value is -- given. We use these here to include in comments when we write out the@@ -270,6 +296,7 @@   return SavedConfig {     savedGlobalFlags       = commandDefaultFlags globalCommand,     savedInstallFlags      = defaultInstallFlags,+    savedConfigureExFlags  = defaultConfigExFlags,     savedConfigureFlags    = (defaultConfigFlags defaultProgramConfiguration) {       configUserInstall    = toFlag defaultUserInstall     },@@ -285,26 +312,41 @@       toSavedConfig liftGlobalFlag        (commandOptions globalCommand ParseArgs)-       ["version", "numeric-version", "config-file"]--  ++ toSavedConfig liftInstallFlag-       (installOptions ParseArgs)-       ["dry-run", "reinstall", "only"]+       ["version", "numeric-version", "config-file"] []    ++ toSavedConfig liftConfigFlag        (configureOptions ParseArgs)-       (["scratchdir", "configure-option"] ++ map fieldName installDirsFields)+       (["builddir", "configure-option"] ++ map fieldName installDirsFields) +        --FIXME: this is only here because viewAsFieldDescr gives us a parser+        -- that only recognises 'ghc' etc, the case-sensitive flag names, not+        -- what the normal case-insensitive parser gives us.+       [simpleField "compiler"+          (fromFlagOrDefault Disp.empty . fmap Text.disp) (optional Text.parse)+          configHcFlavor (\v flags -> flags { configHcFlavor = v })+       ]++  ++ toSavedConfig liftConfigExFlag+       (configureExOptions ParseArgs)+       [] []++  ++ toSavedConfig liftInstallFlag+       (installOptions ParseArgs)+       ["dry-run", "reinstall", "only"] []+   ++ toSavedConfig liftUploadFlag        (commandOptions uploadCommand ParseArgs)-       ["verbose", "check"]+       ["verbose", "check"] []    where-    toSavedConfig lift options excluded =-      [ lift field+    toSavedConfig lift options exclusions replacements =+      [ lift (fromMaybe field replacement)       | opt <- options-      , let field = viewAsFieldDescr opt-      , fieldName field `notElem` excluded ]+      , let field       = viewAsFieldDescr opt+            name        = fieldName field+            replacement = find ((== name) . fieldName) replacements+      , name `notElem` exclusions ]+    optional = Parse.option mempty . fmap toFlag  -- TODO: next step, make the deprecated fields elicit a warning. --@@ -354,6 +396,10 @@ liftConfigFlag = liftField   savedConfigureFlags (\flags conf -> conf { savedConfigureFlags = flags }) +liftConfigExFlag :: FieldDescr ConfigExFlags -> FieldDescr SavedConfig+liftConfigExFlag = liftField+  savedConfigureExFlags (\flags conf -> conf { savedConfigureExFlags = flags })+ liftInstallFlag :: FieldDescr InstallFlags -> FieldDescr SavedConfig liftInstallFlag = liftField   savedInstallFlags (\flags conf -> conf { savedInstallFlags = flags })@@ -367,7 +413,9 @@   fields <- readFields str   let (knownSections, others) = partition isKnownSection fields   config <- parse others-  (user, global) <- foldM parseSections (mempty, mempty) knownSections+  let user0   = savedUserInstallDirs config+      global0 = savedGlobalInstallDirs config+  (user, global) <- foldM parseSections (user0, global0) knownSections   return config {     savedUserInstallDirs   = user,     savedGlobalInstallDirs = global@@ -505,4 +553,6 @@       reqArgFlag "DIR" _sf _lf d         (fmap fromPathTemplate . get) (set . fmap toPathTemplate) -    reqArgFlag ad = reqArg ad (succeedReadE toFlag) flagToList+    reqArgFlag ad = reqArg ad (fmap toFlag (readP_to_E err parseFilePathQ))+                              (map (show . showFilePath) . flagToList)+      where err _ = "paths with spaces must use Haskell String syntax"

+ Distribution/Client/Configure.hs view

@@ -0,0 +1,210 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Configure+-- Copyright   :  (c) David Himmelstrup 2005,+--                    Duncan Coutts 2005+-- License     :  BSD-like+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- High level interface to configuring a package.+-----------------------------------------------------------------------------+module Distribution.Client.Configure (+    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+         ( getAvailablePackages )+import Distribution.Client.Setup+         ( ConfigExFlags(..), configureCommand, filterConfigureFlags )+import Distribution.Client.Types as Available+         ( AvailablePackage(..), AvailablePackageSource(..), Repo(..)+         , AvailablePackageDb(..), ConfiguredPackage(..) )+import Distribution.Client.SetupWrapper+         ( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions )++import Distribution.Simple.Compiler+         ( CompilerId(..), Compiler(compilerId), PackageDB(..) )+import Distribution.Simple.Program (ProgramConfiguration )+import Distribution.Simple.Configure (getInstalledPackages)+import Distribution.Simple.Setup+         ( ConfigFlags(..), toFlag, flagToMaybe, fromFlagOrDefault )+import qualified Distribution.Simple.PackageIndex as PackageIndex+import Distribution.Simple.PackageIndex (PackageIndex)+import Distribution.Simple.Utils+         ( defaultPackageDesc )+import Distribution.Package+         ( PackageName, packageName, packageVersion+         , Package(..), Dependency(..), thisPackageVersion )+import qualified Distribution.PackageDescription as PackageDescription+import Distribution.PackageDescription+         ( PackageDescription )+import Distribution.PackageDescription.Parse+         ( readPackageDescription )+import Distribution.PackageDescription.Configuration+         ( finalizePackageDescription )+import Distribution.InstalledPackageInfo+         ( InstalledPackageInfo )+import Distribution.Version+         ( VersionRange(AnyVersion, ThisVersion) )+import Distribution.Simple.Utils as Utils+         ( notice, info, die )+import Distribution.System+         ( Platform(Platform), buildPlatform )+import Distribution.Verbosity as Verbosity+         ( Verbosity )++-- | Configure the package found in the local directory+configure :: Verbosity+          -> PackageDB+          -> [Repo]+          -> Compiler+          -> ProgramConfiguration+          -> ConfigFlags+          -> ConfigExFlags+          -> [String]+          -> IO ()+configure verbosity packageDB repos comp conf+  configFlags configExFlags extraArgs = do++  installed <- getInstalledPackages verbosity comp packageDB conf+  available <- getAvailablePackages verbosity repos++  progress <- planLocalPackage verbosity comp configFlags configExFlags+                               installed available++  notice verbosity "Resolving dependencies..."+  maybePlan <- foldProgress (\message rest -> info verbosity message >> rest)+                            (return . Left) (return . Right) progress+  case maybePlan of+    Left message -> do+      info verbosity message+      setupWrapper verbosity (setupScriptOptions installed) Nothing+        configureCommand (const configFlags) extraArgs++    Right installPlan -> case InstallPlan.ready installPlan of+      [pkg@(ConfiguredPackage (AvailablePackage _ _ LocalUnpackedPackage) _ _)] ->+        configurePackage verbosity+          (InstallPlan.planPlatform installPlan)+          (InstallPlan.planCompiler installPlan)+          (setupScriptOptions installed)+          configFlags pkg extraArgs++      _ -> die $ "internal error: configure install plan should have exactly "+              ++ "one local ready package."++  where+    setupScriptOptions index = SetupScriptOptions {+      useCabalVersion  = maybe AnyVersion ThisVersion+                         (flagToMaybe (configCabalVersion configExFlags)),+      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.+      -- TODO: if we specify a specific db then we do not look in the user+      --       package db but we probably should ie [global, user, specific]+      usePackageDB     = if packageDB == GlobalPackageDB then UserPackageDB+                                                         else packageDB,+      usePackageIndex  = if packageDB == GlobalPackageDB then Nothing+                                                         else index,+      useProgramConfig = conf,+      useDistPref      = fromFlagOrDefault+                           (useDistPref defaultSetupScriptOptions)+                           (configDistPref configFlags),+      useLoggingHandle = Nothing,+      useWorkingDir    = Nothing+    }++-- | Make an 'InstallPlan' for the unpacked package in the current directory,+-- and all its dependencies.+--+planLocalPackage :: Verbosity -> Compiler+                 -> ConfigFlags -> ConfigExFlags+                 -> Maybe (PackageIndex InstalledPackageInfo)+                 -> AvailablePackageDb+                 -> IO (Progress String String InstallPlan)+planLocalPackage verbosity comp configFlags configExFlags installed+  (AvailablePackageDb _ 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 mempty+      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+++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 ]++-- | 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+-- versioned package dependencies. So we ignore any previous partial flag+-- assignment or dependency constraints and use the new ones.+--+configurePackage :: Verbosity+                 -> Platform -> CompilerId+                 -> SetupScriptOptions+                 -> ConfigFlags+                 -> ConfiguredPackage+                 -> [String]+                 -> IO ()+configurePackage verbosity (Platform arch os) comp scriptOptions configFlags+  (ConfiguredPackage (AvailablePackage _ gpkg _) flags deps) extraArgs =++  setupWrapper verbosity+    scriptOptions (Just pkg) configureCommand configureFlags extraArgs++  where+    configureFlags   = filterConfigureFlags configFlags {+      configConfigurationsFlags = flags,+      configConstraints         = map thisPackageVersion deps,+      configVerbosity           = toFlag verbosity+    }++    pkg = case finalizePackageDescription flags+           (Nothing :: Maybe (PackageIndex PackageDescription))+           os arch comp [] gpkg of+      Left _ -> error "finalizePackageDescription ConfiguredPackage failed"+      Right (desc, _) -> desc

Distribution/Client/Dependency.hs view

@@ -13,13 +13,16 @@ -- Top level interface to dependency resolution. ----------------------------------------------------------------------------- module Distribution.Client.Dependency (+    module Distribution.Client.Dependency.Types,     resolveDependencies,     resolveDependenciesWithProgress, +    dependencyConstraints,+    dependencyTargets,+     PackagesPreference(..),-    packagesPreference,-    PackagesVersionPreference,-    PackagesInstalledPreference(..),+    PackagesPreferenceDefault(..),+    PackagePreference(..),      upgradableDependencies,   ) where@@ -34,18 +37,18 @@ import Distribution.Client.Types          ( UnresolvedDependency(..), AvailablePackage(..) ) import Distribution.Client.Dependency.Types-         ( PackageName, DependencyResolver-         , PackagePreference(..), PackageInstalledPreference(..)+         ( DependencyResolver, PackageConstraint(..)+         , PackagePreferences(..), InstalledPreference(..)          , Progress(..), foldProgress ) import Distribution.Package          ( PackageIdentifier(..), PackageName(..), packageVersion, packageName          , Dependency(..), Package(..), PackageFixedDeps(..) ) import Distribution.Version-         ( VersionRange(AnyVersion), orLaterVersion )+         ( VersionRange(AnyVersion), orLaterVersion, isAnyVersion ) import Distribution.Compiler-         ( CompilerId )+         ( CompilerId(..) ) import Distribution.System-         ( OS, Arch )+         ( Platform ) import Distribution.Simple.Utils (comparing) import Distribution.Client.Utils (mergeBy, MergeResult(..)) @@ -53,7 +56,6 @@ import Data.Monoid (Monoid(mempty)) import Data.Maybe (fromMaybe) import qualified Data.Map as Map-import Data.Map (Map) import qualified Data.Set as Set import Data.Set (Set) import Control.Exception (assert)@@ -64,27 +66,27 @@ -- | Global policy for the versions of all packages. -- data PackagesPreference = PackagesPreference-       PackagesInstalledPreference-       PackagesVersionPreference+       PackagesPreferenceDefault+       [PackagePreference] -packagesPreference :: PackagesInstalledPreference-                   -> Map PackageName VersionRange-                   -> PackagesPreference-packagesPreference installedPref versionPrefs =-  PackagesPreference installedPref versionPrefs'-  where-    versionPrefs' :: PackageName -> VersionRange-    versionPrefs' pkgname =-      fromMaybe AnyVersion (Map.lookup pkgname versionPrefs)+dependencyConstraints :: [UnresolvedDependency] -> [PackageConstraint]+dependencyConstraints deps =+     [ PackageVersionConstraint name versionRange+     | UnresolvedDependency (Dependency name versionRange) _ <- deps+     , not (isAnyVersion versionRange) ] --- | An optional suggested version for each package.----type PackagesVersionPreference = PackageName -> 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. ---data PackagesInstalledPreference =+data PackagesPreferenceDefault =       -- | Always prefer the latest version irrespective of any existing      -- installed version.@@ -105,31 +107,37 @@      --    | PreferLatestForSelected -resolveDependencies :: OS-                    -> Arch+data PackagePreference+   = PackageVersionPreference   PackageName VersionRange+   | PackageInstalledPreference PackageName InstalledPreference++resolveDependencies :: Platform                     -> CompilerId                     -> Maybe (PackageIndex InstalledPackageInfo)                     -> PackageIndex AvailablePackage                     -> PackagesPreference-                    -> [UnresolvedDependency]+                    -> [PackageConstraint]+                    -> [PackageName]                     -> Either String InstallPlan-resolveDependencies os arch comp installed available pref deps =+resolveDependencies platform comp installed available+                    preferences constraints targets =   foldProgress (flip const) Left Right $-    resolveDependenciesWithProgress os arch comp installed available pref deps+    resolveDependenciesWithProgress platform comp installed available+                                    preferences constraints targets -resolveDependenciesWithProgress :: OS-                                -> Arch+resolveDependenciesWithProgress :: Platform                                 -> CompilerId                                 -> Maybe (PackageIndex InstalledPackageInfo)                                 -> PackageIndex AvailablePackage                                 -> PackagesPreference-                                -> [UnresolvedDependency]+                                -> [PackageConstraint]+                                -> [PackageName]                                 -> Progress String String InstallPlan-resolveDependenciesWithProgress os arch comp (Just installed) =-  dependencyResolver defaultResolver os arch comp installed+resolveDependenciesWithProgress platform comp (Just installed) =+  dependencyResolver defaultResolver platform comp installed -resolveDependenciesWithProgress os arch comp Nothing =-  dependencyResolver bogusResolver os arch comp mempty+resolveDependenciesWithProgress platform comp Nothing =+  dependencyResolver bogusResolver platform comp mempty  hideBrokenPackages :: PackageFixedDeps p => PackageIndex p -> PackageIndex p hideBrokenPackages index =@@ -141,53 +149,70 @@   where     check p x = assert (p x) x -hideBasePackage :: Package p => PackageIndex p -> PackageIndex p-hideBasePackage = PackageIndex.deletePackageName (PackageName "base")-                . PackageIndex.deletePackageName (PackageName "ghc-prim")- dependencyResolver   :: DependencyResolver-  -> OS -> Arch -> CompilerId+  -> Platform -> CompilerId   -> PackageIndex InstalledPackageInfo   -> PackageIndex AvailablePackage   -> PackagesPreference-  -> [UnresolvedDependency]+  -> [PackageConstraint]+  -> [PackageName]   -> Progress String String InstallPlan-dependencyResolver resolver os arch comp installed available pref deps =+dependencyResolver resolver platform comp installed available+                            pref constraints targets =   let installed' = hideBrokenPackages installed-      available' = hideBasePackage available+      -- 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 os arch comp installed' available' preference deps+    $ resolver platform comp installed' available+               preferences (extraConstraints ++ constraints) targets    where     toPlan pkgs =-      case InstallPlan.new os arch comp (PackageIndex.fromList pkgs) of+      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 -    preference = interpretPackagesPreference initialPkgNames pref-    initialPkgNames = Set.fromList-      [ name | UnresolvedDependency (Dependency name _) _ <- deps ]- -- | Give an interpretation to the global 'PackagesPreference' as --  specific per-package 'PackageVersionPreference'. -- interpretPackagesPreference :: Set PackageName                             -> PackagesPreference-                            -> (PackageName -> PackagePreference)-interpretPackagesPreference selected-  (PackagesPreference installPref versionPref) = case installPref of-    PreferAllLatest    -> PackagePreference PreferLatest    . versionPref-    PreferAllInstalled -> PackagePreference PreferInstalled . versionPref-    PreferLatestForSelected -> \pkgname ->-      -- When you say cabal install foo, what you really mean is, prefer the-      -- latest version of foo, but the installed version of everything else:-      if pkgname `Set.member` selected-        then PackagePreference PreferLatest    (versionPref pkgname)-        else PackagePreference PreferInstalled (versionPref pkgname)+                            -> (PackageName -> PackagePreferences)+interpretPackagesPreference selected (PackagesPreference defaultPref prefs) =+  \pkgname -> PackagePreferences (versionPref pkgname) (installPref pkgname)++  where+    versionPref pkgname =+      fromMaybe AnyVersion (Map.lookup pkgname versionPrefs)+    versionPrefs = Map.fromList+      [ (pkgname, pref)+      | PackageVersionPreference pkgname pref <- prefs ]++    installPref pkgname =+      fromMaybe (installPrefDefault pkgname) (Map.lookup pkgname installPrefs)+    installPrefs = Map.fromList+      [ (pkgname, pref)+      | PackageInstalledPreference pkgname pref <- prefs ]+    installPrefDefault = case defaultPref of+      PreferAllLatest         -> \_       -> PreferLatest+      PreferAllInstalled      -> \_       -> PreferInstalled+      PreferLatestForSelected -> \pkgname ->+        -- When you say cabal install foo, what you really mean is, prefer the+        -- latest version of foo, but the installed version of everything else+        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.

Distribution/Client/Dependency/Bogus.hs view

@@ -16,14 +16,15 @@   ) where  import Distribution.Client.Types-         ( UnresolvedDependency(..), AvailablePackage(..)-         , ConfiguredPackage(..) )+         ( AvailablePackage(..), ConfiguredPackage(..) ) import Distribution.Client.Dependency.Types-         ( DependencyResolver, Progress(..) )+         ( DependencyResolver, Progress(..)+         , PackageConstraint(..), PackagePreferences(..) ) import qualified Distribution.Client.InstallPlan as InstallPlan  import Distribution.Package-         ( PackageIdentifier(..), Dependency(..), Package(..) )+         ( PackageName, PackageIdentifier(..), Dependency(..)+         , Package(..), packageVersion ) import Distribution.PackageDescription          ( GenericPackageDescription(..), CondTree(..), FlagAssignment ) import Distribution.PackageDescription.Configuration@@ -31,14 +32,19 @@ import qualified Distribution.Simple.PackageIndex as PackageIndex import Distribution.Simple.PackageIndex (PackageIndex) import Distribution.Version-         ( VersionRange(IntersectVersionRanges) )+         ( VersionRange(AnyVersion, IntersectVersionRanges), withinRange ) import Distribution.Simple.Utils-         ( equating, comparing )+         ( comparing ) import Distribution.Text          ( display )+import Distribution.System+         ( Platform(Platform) )  import Data.List-         ( maximumBy, sortBy, groupBy )+         ( maximumBy )+import Data.Maybe+         ( fromMaybe )+import qualified Data.Map as Map  -- | This resolver thinks that every package is already installed. --@@ -46,12 +52,14 @@ -- We just pretend that everything is installed and hope for the best. -- bogusResolver :: DependencyResolver-bogusResolver os arch comp _ available _ = resolveFromAvailable []-                                         . combineDependencies+bogusResolver (Platform arch os) comp _ available+              preferences constraints targets =+    resolveFromAvailable []+      (combineConstraints preferences constraints targets)   where     resolveFromAvailable chosen [] = Done chosen-    resolveFromAvailable chosen (UnresolvedDependency dep flags : deps) =-      case latestAvailableSatisfying available dep of+    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 os arch comp [] pkg of@@ -64,6 +72,8 @@           where             none :: Maybe (PackageIndex PackageIdentifier)             none = Nothing+      where+        dep = Dependency name verConstraint  fudgeChosenPackage :: AvailablePackage -> FlagAssignment -> ConfiguredPackage fudgeChosenPackage (AvailablePackage pkgid pkg source) flags =@@ -87,23 +97,35 @@       where         g (cnd, t, me) = (cnd, mapTreeConstrs f t, fmap (mapTreeConstrs f) me) -combineDependencies :: [UnresolvedDependency] -> [UnresolvedDependency]-combineDependencies = map combineGroup-                    . groupBy (equating depName)-                    . sortBy  (comparing depName)+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-    combineGroup deps = UnresolvedDependency (Dependency name ver) flags-      where name  = depName (head deps)-            ver   = foldr1 IntersectVersionRanges . map depVer $ deps-            flags = concatMap depFlags deps-    depName (UnresolvedDependency (Dependency name _) _) = name-    depVer  (UnresolvedDependency (Dependency _ ver)  _) = ver+    versionConstraints = Map.fromListWith IntersectVersionRanges+      [ (name, versionRange)+      | PackageVersionConstraint name versionRange <- constraints ] --- | Gets the latest available package satisfying a dependency.+    flagsConstraints =  Map.fromListWith (++)+      [ (name, flags)+      | PackageFlagsConstraint name flags <- constraints ]++-- | Gets the best available package satisfying a dependency.+-- latestAvailableSatisfying :: PackageIndex AvailablePackage-                          -> Dependency+                          -> PackageName -> VersionRange -> VersionRange                           -> Maybe AvailablePackage-latestAvailableSatisfying index dep =+latestAvailableSatisfying index name versionConstraint versionPreference =   case PackageIndex.lookupDependency index dep of     []   -> Nothing-    pkgs -> Just (maximumBy (comparing (pkgVersion . packageId)) pkgs)+    pkgs -> Just (maximumBy best pkgs)+  where+    dep  = Dependency name versionConstraint+    best = comparing (\p -> (isPreferred p, packageVersion p))+    isPreferred p = packageVersion p `withinRange` versionPreference

Distribution/Client/Dependency/TopDown.hs view

@@ -22,11 +22,10 @@ import Distribution.Client.InstallPlan          ( PlanPackage(..) ) import Distribution.Client.Types-         ( UnresolvedDependency(..), AvailablePackage(..)-         , ConfiguredPackage(..) )+         ( AvailablePackage(..), ConfiguredPackage(..) ) import Distribution.Client.Dependency.Types-         ( PackageName, DependencyResolver, PackagePreference(..)-         , PackageInstalledPreference(..)+         ( DependencyResolver, PackageConstraint(..)+         , PackagePreferences(..), InstalledPreference(..)          , Progress(..), foldProgress )  import qualified Distribution.Simple.PackageIndex as PackageIndex@@ -42,11 +41,11 @@ import Distribution.PackageDescription.Configuration          ( finalizePackageDescription, flattenPackageDescription ) import Distribution.Version-         ( withinRange )+         ( VersionRange(AnyVersion), withinRange ) import Distribution.Compiler          ( CompilerId ) import Distribution.System-         ( OS, Arch )+         ( Platform(Platform) ) import Distribution.Simple.Utils          ( equating, comparing ) import Distribution.Text@@ -55,7 +54,7 @@ import Data.List          ( foldl', maximumBy, minimumBy, nub, sort, groupBy ) import Data.Maybe-         ( fromJust, fromMaybe )+         ( fromJust, fromMaybe, catMaybes ) import Data.Monoid          ( Monoid(mempty) ) import Control.Monad@@ -65,6 +64,8 @@ import qualified Data.Map as Map import qualified Data.Graph as Graph import qualified Data.Array as Array+import Control.Exception+         ( assert )  -- ------------------------------------------------------------ -- * Search state types@@ -86,7 +87,7 @@ -- * Traverse a search tree -- ------------------------------------------------------------ -explore :: (PackageName -> PackagePreference)+explore :: (PackageName -> PackagePreferences)         -> SearchSpace (SelectedPackages, Constraints, SelectionChanges)                        SelectablePackage         -> Progress Log Failure (SelectedPackages, Constraints)@@ -116,7 +117,7 @@         isInstalled (AvailableOnly _) = False         isInstalled _                 = True         isPreferred p = packageVersion p `withinRange` preferredVersions-        (PackagePreference packageInstalledPreference preferredVersions)+        (PackagePreferences preferredVersions packageInstalledPreference)           = pref pkgname      logInfo node = Select selected discarded@@ -209,7 +210,7 @@ -- ------------------------------------------------------------  search :: ConfigurePackage-       -> (PackageName -> PackagePreference)+       -> (PackageName -> PackagePreferences)        -> Constraints        -> Set PackageName        -> Progress Log Failure (SelectedPackages, Constraints)@@ -231,45 +232,65 @@  -- | The native resolver with detailed structured logging and failure types. ---topDownResolver' :: OS -> Arch -> CompilerId+topDownResolver' :: Platform -> CompilerId                  -> PackageIndex InstalledPackageInfo                  -> PackageIndex AvailablePackage-                 -> (PackageName -> PackagePreference)-                 -> [UnresolvedDependency]+                 -> (PackageName -> PackagePreferences)+                 -> [PackageConstraint]+                 -> [PackageName]                  -> Progress Log Failure [PlanPackage]-topDownResolver' os arch comp installed available pref deps =+topDownResolver' platform comp installed available+                 preferences constraints targets =       fmap (uncurry finalise)-    . (\cs -> search configure pref cs initialPkgNames)-  =<< constrainTopLevelDeps deps constraints+    . (\cs -> search configure preferences cs initialPkgNames)+  =<< addTopLevelConstraints constraints constraintSet    where-    configure   = configurePackage os arch comp-    constraints = Constraints.empty-                    (annotateInstalledPackages      topSortNumber installed')-                    (annotateAvailablePackages deps topSortNumber available')+    configure   = configurePackage platform comp+    constraintSet = Constraints.empty+      (annotateInstalledPackages             topSortNumber installed')+      (annotateAvailablePackages constraints topSortNumber available')     (installed', available') = selectNeededSubset installed available                                                   initialPkgNames     topSortNumber = topologicalSortNumbering installed' available' -    initialDeps     = [ dep  | UnresolvedDependency dep _ <- deps ]-    initialPkgNames = Set.fromList [ name | Dependency name _ <- initialDeps ]+    initialPkgNames = Set.fromList targets -    finalise selected = PackageIndex.allPackages-                      . improvePlan installed'-                      . PackageIndex.fromList-                      . finaliseSelectedPackages pref selected+    finalise selected' constraints' =+        PackageIndex.allPackages+      . fst . improvePlan installed' constraints'+      . PackageIndex.fromList+      $ finaliseSelectedPackages preferences selected' constraints' -constrainTopLevelDeps :: [UnresolvedDependency] -> Constraints-                      -> Progress a Failure Constraints-constrainTopLevelDeps []                                cs = Done cs-constrainTopLevelDeps (UnresolvedDependency dep _:deps) cs =-  case addTopLevelDependencyConstraint dep cs of-    Satisfiable cs' _       -> constrainTopLevelDeps deps cs'-    Unsatisfiable           -> Fail (TopLevelDependencyUnsatisfiable dep)-    ConflictsWith conflicts -> Fail (TopLevelDependencyConflict dep conflicts)+addTopLevelConstraints :: [PackageConstraint] -> Constraints+                       -> Progress a Failure Constraints+addTopLevelConstraints []                                      cs = Done cs+addTopLevelConstraints (PackageFlagsConstraint   _   _  :deps) cs =+  addTopLevelConstraints deps cs -configurePackage :: OS -> Arch -> CompilerId -> ConfigurePackage-configurePackage os arch comp available spkg = case spkg of+addTopLevelConstraints (PackageVersionConstraint pkg ver:deps) cs =+  case addTopLevelVersionConstraint pkg ver cs of+    Satisfiable cs' _       ->+      addTopLevelConstraints deps cs'++    Unsatisfiable           ->+      Fail (TopLevelVersionConstraintUnsatisfiable pkg ver)++    ConflictsWith conflicts ->+      Fail (TopLevelVersionConstraintConflict pkg ver conflicts)++addTopLevelConstraints (PackageInstalledConstraint pkg:deps) cs =+  case addTopLevelInstalledConstraint pkg cs of+    Satisfiable cs' _       -> addTopLevelConstraints deps cs'++    Unsatisfiable           ->+      Fail (TopLevelInstallConstraintUnsatisfiable pkg)++    ConflictsWith conflicts ->+      Fail (TopLevelInstallConstraintConflict pkg conflicts)++configurePackage :: Platform -> CompilerId -> ConfigurePackage+configurePackage (Platform arch os) comp available spkg = case spkg of   InstalledOnly         ipkg      -> Right (InstalledOnly ipkg)   AvailableOnly              apkg -> fmap AvailableOnly (configure apkg)   InstalledAndAvailable ipkg apkg -> fmap (InstalledAndAvailable ipkg)@@ -300,11 +321,11 @@ -- | Annotate each available packages with its topological sort number and any -- user-supplied partial flag assignment. ---annotateAvailablePackages :: [UnresolvedDependency]+annotateAvailablePackages :: [PackageConstraint]                           -> (PackageName -> TopologicalSortNumber)                           -> PackageIndex AvailablePackage                           -> PackageIndex UnconfiguredPackage-annotateAvailablePackages deps dfsNumber available = PackageIndex.fromList+annotateAvailablePackages constraints dfsNumber available = PackageIndex.fromList   [ UnconfiguredPackage pkg (dfsNumber name) (flagsFor name)   | pkg <- PackageIndex.allPackages available   , let name = packageName pkg ]@@ -312,7 +333,7 @@     flagsFor = fromMaybe [] . flip Map.lookup flagsMap     flagsMap = Map.fromList       [ (name, flags)-      | UnresolvedDependency (Dependency name _) flags <- deps ]+      | PackageFlagsConstraint name flags <- constraints ]  -- | One of the heuristics we use when guessing which path to take in the -- search space is an ordering on the choices we make. It's generally better@@ -400,7 +421,7 @@ -- * Post processing the solution -- ------------------------------------------------------------ -finaliseSelectedPackages :: (PackageName -> PackagePreference)+finaliseSelectedPackages :: (PackageName -> PackagePreferences)                          -> SelectedPackages                          -> Constraints                          -> [PlanPackage]@@ -426,7 +447,8 @@           case PackageIndex.lookupDependency remainingChoices dep of             []        -> impossible             [pkg']    -> pkg'-            remaining -> maximumBy bestByPref remaining+            remaining -> assert (checkIsPaired remaining)+                       $ maximumBy bestByPref remaining         -- We order candidate packages to pick for a dependency by these         -- three factors. The last factor is just highest version wins.         bestByPref =@@ -440,39 +462,74 @@         -- Is this package a preferred version acording to the hackage or         -- user's suggested version constraints         isPreferred p = packageVersion p `withinRange` preferredVersions-          where (PackagePreference _ preferredVersions) = pref (packageName p)+          where (PackagePreferences preferredVersions _) = pref (packageName p) +        -- We really only expect to find more than one choice remaining when+        -- we're finalising a dependency on a paired package.+        checkIsPaired [p1, p2] =+          case Constraints.isPaired constraints (packageId p1) of+            Just p2'   -> packageId p2' == packageId p2+            Nothing    -> False+        checkIsPaired _ = False+ -- | Improve an existing installation plan by, where possible, swapping -- packages we plan to install with ones that are already installed.+-- This may add additional constraints due to the dependencies of installed+-- packages on other installed packages. -- improvePlan :: PackageIndex InstalledPackageInfo-            -> PackageIndex PlanPackage+            -> Constraints             -> PackageIndex PlanPackage-improvePlan installed selected = foldl' improve selected-                               $ reverseTopologicalOrder selected+            -> (PackageIndex PlanPackage, Constraints)+improvePlan installed constraints0 selected0 =+  foldl' improve (selected0, constraints0) (reverseTopologicalOrder selected0)   where-    improve selected' = maybe selected' (flip PackageIndex.insert selected')-                      . improvePkg selected'+    improve (selected, constraints) = fromMaybe (selected, constraints)+                                    . improvePkg selected constraints      -- The idea is to improve the plan by swapping a configured package for     -- an equivalent installed one. For a particular package the condition is     -- that the package be in a configured state, that a the same version be     -- already installed with the exact same dependencies and all the packages     -- in the plan that it depends on are in the installed state-    improvePkg selected' pkgid = do-      Configured pkg  <- PackageIndex.lookupPackageId selected' pkgid+    improvePkg selected constraints pkgid = do+      Configured pkg  <- PackageIndex.lookupPackageId selected  pkgid       ipkg            <- PackageIndex.lookupPackageId installed pkgid-      guard $ sort (depends pkg) == nub (sort (depends ipkg))-      guard $ all (isInstalled selected') (depends pkg)-      return (PreExisting ipkg)+      guard $ all (isInstalled selected) (depends pkg)+      tryInstalled selected constraints [ipkg] -    isInstalled selected' pkgid =-      case PackageIndex.lookupPackageId selected' pkgid of+    isInstalled selected pkgid =+      case PackageIndex.lookupPackageId selected pkgid of         Just (PreExisting _) -> True         _                    -> False -    reverseTopologicalOrder :: PackageFixedDeps pkg => PackageIndex pkg-                            -> [PackageIdentifier]+    tryInstalled :: PackageIndex PlanPackage -> Constraints+                 -> [InstalledPackageInfo]+                 -> Maybe (PackageIndex PlanPackage, Constraints)+    tryInstalled selected constraints [] = Just (selected, constraints)+    tryInstalled selected constraints (pkg:pkgs) =+      case constraintsOk (packageId pkg) (depends pkg) constraints of+        Nothing           -> Nothing+        Just constraints' -> tryInstalled selected' constraints' pkgs'+          where+            selected' = PackageIndex.insert (PreExisting pkg) selected+            pkgs'      = catMaybes (map notSelected (depends pkg)) ++ pkgs+            notSelected pkgid =+              case (PackageIndex.lookupPackageId installed pkgid+                   ,PackageIndex.lookupPackageId selected  pkgid) of+                (Just pkg', Nothing) -> Just pkg'+                _                    -> Nothing++    constraintsOk _     []              constraints = Just constraints+    constraintsOk pkgid (pkgid':pkgids) constraints =+      case addPackageDependencyConstraint pkgid dep constraints of+        Satisfiable constraints' _ -> constraintsOk pkgid pkgids constraints'+        _                          -> Nothing+      where+        dep = TaggedDependency InstalledConstraint (thisPackageVersion pkgid')++    reverseTopologicalOrder :: PackageFixedDeps pkg+                            => PackageIndex pkg -> [PackageIdentifier]     reverseTopologicalOrder index = map (packageId . toPkg)                                   . Graph.topSort                                   . Graph.transposeG@@ -493,8 +550,8 @@     reason = SelectedOther pkgid  addPackageExcludeConstraint :: PackageIdentifier -> Constraints-                     -> Satisfiable Constraints-                          [PackageIdentifier] ExclusionReason+                            -> Satisfiable Constraints+                                 [PackageIdentifier] ExclusionReason addPackageExcludeConstraint pkgid constraints =   Constraints.constrain dep reason constraints   where@@ -510,15 +567,28 @@   where     reason = ExcludedByPackageDependency pkgid dep -addTopLevelDependencyConstraint :: Dependency -> Constraints-                                -> Satisfiable Constraints-                                     [PackageIdentifier] ExclusionReason-addTopLevelDependencyConstraint dep constraints =+addTopLevelVersionConstraint :: PackageName -> VersionRange+                             -> Constraints+                             -> Satisfiable Constraints+                                  [PackageIdentifier] ExclusionReason+addTopLevelVersionConstraint pkg ver constraints =   Constraints.constrain taggedDep reason constraints   where+    dep       = Dependency pkg ver     taggedDep = TaggedDependency NoInstalledConstraint dep-    reason = ExcludedByTopLevelDependency dep+    reason    = ExcludedByTopLevelDependency dep +addTopLevelInstalledConstraint :: PackageName+                               -> Constraints+                               -> Satisfiable Constraints+                                    [PackageIdentifier] ExclusionReason+addTopLevelInstalledConstraint pkg constraints =+  Constraints.constrain taggedDep reason constraints+  where+    dep       = Dependency pkg AnyVersion+    taggedDep = TaggedDependency InstalledConstraint dep+    reason    = ExcludedByTopLevelDependency dep+ -- ------------------------------------------------------------ -- * Reasons for constraints -- ------------------------------------------------------------@@ -575,11 +645,16 @@    | DependencyConflict        SelectedPackage TaggedDependency        [(PackageIdentifier, [ExclusionReason])]-   | TopLevelDependencyConflict-       Dependency+   | TopLevelVersionConstraintConflict+       PackageName VersionRange        [(PackageIdentifier, [ExclusionReason])]-   | TopLevelDependencyUnsatisfiable-       Dependency+   | TopLevelVersionConstraintUnsatisfiable+       PackageName VersionRange+   | TopLevelInstallConstraintConflict+       PackageName+       [(PackageIdentifier, [ExclusionReason])]+   | TopLevelInstallConstraintUnsatisfiable+       PackageName  showLog :: Log -> String showLog (Select selected discarded) = case (selectedMsg, discardedMsg) of@@ -633,15 +708,24 @@   ++ unlines [ showExclusionReason (packageId pkg') reason              | (pkg', reasons) <- conflicts, reason <- reasons ] -showFailure (TopLevelDependencyConflict dep conflicts) =-     "dependencies conflict: "-  ++ "top level dependency " ++ display dep ++ " however\n"+showFailure (TopLevelVersionConstraintConflict name ver conflicts) =+     "constraints conflict: "+  ++ "top level constraint " ++ display (Dependency name ver) ++ " however\n"   ++ unlines [ showExclusionReason (packageId pkg') reason              | (pkg', reasons) <- conflicts, reason <- reasons ] -showFailure (TopLevelDependencyUnsatisfiable (Dependency name ver)) =+showFailure (TopLevelVersionConstraintUnsatisfiable name ver) =      "There is no available version of " ++ display name       ++ " that satisfies " ++ display ver++showFailure (TopLevelInstallConstraintConflict name conflicts) =+     "constraints conflict: "+  ++ "top level constraint " ++ display name ++ "-installed however\n"+  ++ unlines [ showExclusionReason (packageId pkg') reason+             | (pkg', reasons) <- conflicts, reason <- reasons ]++showFailure (TopLevelInstallConstraintUnsatisfiable name) =+     "There is no installed version of " ++ display name  -- ------------------------------------------------------------ -- * Utils

Distribution/Client/Dependency/TopDown/Constraints.hs view

@@ -15,7 +15,7 @@   empty,   choices,   isPaired,-  +   constrain,   Satisfiable(..),   conflicting,@@ -55,7 +55,7 @@         -- Remaining available choices        (PackageIndex (InstalledOrAvailable installed available))-       +        -- Paired choices        (Map PackageName (Version, Version)) @@ -63,6 +63,10 @@        -- usually by applying constraints        (PackageIndex (ExcludedPackage PackageIdentifier reason)) +       -- Purely for the invariant, we keep a copy of the original index+       (PackageIndex (InstalledOrAvailable installed available))++ data ExcludedPackage pkg reason    = ExcludedPackage pkg [reason] -- reasons for excluding just the available                          [reason] -- reasons for excluding installed and avail@@ -70,25 +74,63 @@ instance Package pkg => Package (ExcludedPackage pkg reason) where   packageId (ExcludedPackage p _ _) = packageId p --- | The intersection between the two indexes is empty+-- | There is a conservation of packages property. Packages are never gained or+-- lost, they just transfer from the remaining pot to the excluded pot.+-- invariant :: (Package installed, Package available)           => Constraints installed available a -> Bool-invariant (Constraints available _ excluded) =-  all (uncurry ok) [ (a, e) | InBoth a e <- merged ]+invariant (Constraints available _ excluded original) = all check merged   where-    merged = mergeBy (\a b -> packageId a `compare` packageId b)-                     (PackageIndex.allPackages available)-                     (PackageIndex.allPackages excluded)-    ok (InstalledOnly _) (ExcludedPackage _ _ []) = True-    ok _                 _                        = False+    merged = mergeBy (\a b -> packageId a `compare` mergedPackageId b)+                     (PackageIndex.allPackages original)+                     (mergeBy (\a b -> packageId a `compare` packageId b)+                              (PackageIndex.allPackages available)+                              (PackageIndex.allPackages excluded))+      where+        mergedPackageId (OnlyInLeft  p  ) = packageId p+        mergedPackageId (OnlyInRight   p) = packageId p+        mergedPackageId (InBoth      p _) = packageId p +    check (InBoth (InstalledOnly _) cur) = case cur of+      -- If the package was originally installed only then+      -- now it's either still remaining as installed only+      -- or it has been excluded in which case we excluded both+      -- installed and available since it was only installed+      OnlyInLeft  (InstalledOnly _)            -> True+      OnlyInRight (ExcludedPackage _ [] (_:_)) -> True+      _                                        -> False++    check (InBoth (AvailableOnly _) cur) = case cur of+      -- If the package was originally available only then+      -- now it's either still remaining as available only+      -- or it has been excluded in which case we excluded both+      -- installed and available since it was only available+      OnlyInLeft  (AvailableOnly   _)          -> True+      OnlyInRight (ExcludedPackage _ [] (_:_)) -> True+      _                                        -> True++    -- If the package was originally installed and available+    -- then there are three cases.+    check (InBoth (InstalledAndAvailable _ _) cur) = case cur of+      -- We can have both remaining:+      OnlyInLeft                    (InstalledAndAvailable _ _)  -> True+      -- both excluded, in particular it can have had the available excluded+      -- and later had both excluded so we do not mind if the available excluded+      -- is empty or non-empty.+      OnlyInRight                   (ExcludedPackage _ _  (_:_)) -> True+      -- the installed remaining and the available excluded:+      InBoth      (InstalledOnly _) (ExcludedPackage _ (_:_) []) -> True+      _                                                          -> False++    check _ = False+ -- | An update to the constraints can move packages between the two piles -- but not gain or loose packages. transitionsTo :: (Package installed, Package available)               => Constraints installed available a               -> Constraints installed available a -> Bool-transitionsTo constraints @(Constraints available  _ excluded )-              constraints'@(Constraints available' _ excluded') =+transitionsTo constraints @(Constraints available  _ excluded  _)+              constraints'@(Constraints available' _ excluded' _) =      invariant constraints && invariant constraints'   && null availableGained  && null excludedLost   && map packageId availableLost == map packageId excludedGained@@ -102,6 +144,9 @@     availableGained = [ pkg | OnlyInRight pkg <- availableChange ]     excludedLost    = [ pkg | OnlyInLeft  pkg <- excludedChange  ]     excludedGained  = [ pkg | OnlyInRight pkg <- excludedChange  ]+                   ++ [ pkg | InBoth (ExcludedPackage _ (_:_) [])+                                 pkg@(ExcludedPackage _ (_:_) (_:_))+                                              <- excludedChange  ]     availableChange = mergeBy (\a b -> packageId a `compare` packageId b)                               (PackageIndex.allPackages available)                               (PackageIndex.allPackages available')@@ -116,7 +161,7 @@       => PackageIndex installed       -> PackageIndex available       -> Constraints installed available reason-empty installed available = Constraints pkgs pairs mempty+empty installed available = Constraints pkgs pairs mempty pkgs   where     pkgs = PackageIndex.fromList          . map toInstalledOrAvailable@@ -142,12 +187,12 @@ choices :: (Package installed, Package available)         => Constraints installed available reason         -> PackageIndex (InstalledOrAvailable installed available)-choices (Constraints available _ _) = available+choices (Constraints available _ _ _) = available  isPaired :: (Package installed, Package available)          => Constraints installed available reason          -> PackageIdentifier -> Maybe PackageIdentifier-isPaired (Constraints _ pairs _) (PackageIdentifier name version) =+isPaired (Constraints _ pairs _ _) (PackageIdentifier name version) =   case Map.lookup name pairs of     Just (v1, v2)       | version == v1 -> Just (PackageIdentifier name v2)@@ -166,14 +211,14 @@           -> Satisfiable (Constraints installed available reason)                          [PackageIdentifier] reason constrain (TaggedDependency installedConstraint (Dependency name versionRange))-          reason constraints@(Constraints available paired excluded)+          reason constraints@(Constraints available paired excluded original)    | not anyRemaining   = if null conflicts then Unsatisfiable                       else ConflictsWith conflicts -  | otherwise -  = let constraints' = Constraints available' paired excluded'+  | otherwise+  = let constraints' = Constraints available' paired excluded' original      in assert (constraints `transitionsTo` constraints') $         Satisfiable constraints' (map packageId newExcluded) @@ -199,7 +244,7 @@                = id     update pkg = case pkg of       InstalledOnly         _   -> id-      AvailableOnly           _ -> error "impossible" -- PackageIndex.deletePackageId (packageId pkg)+      AvailableOnly           _ -> PackageIndex.deletePackageId (packageId pkg)       InstalledAndAvailable i _ -> PackageIndex.insert (InstalledOnly i)    -- Applying the constraint means adding exclusions for the packages that@@ -215,7 +260,7 @@       = Nothing       | otherwise = case pkg of       InstalledOnly         _   -> Nothing-      AvailableOnly           _ -> Just (ExcludedPackage pkgid [reason] [])+      AvailableOnly           _ -> Just (ExcludedPackage pkgid [] [reason])       InstalledAndAvailable _ _ ->         case PackageIndex.lookupPackageId excluded pkgid of           Just (ExcludedPackage _ avail both)@@ -265,7 +310,7 @@             => Constraints installed available reason             -> Dependency             -> [(PackageIdentifier, [reason])]-conflicting (Constraints _ _ excluded) dep =+conflicting (Constraints _ _ excluded _) dep =   [ (pkgid, reasonsAvail ++ reasonsAll) --TODO   | ExcludedPackage pkgid reasonsAvail reasonsAll <-       PackageIndex.lookupDependency excluded dep ]

Distribution/Client/Dependency/Types.hs view

@@ -11,23 +11,24 @@ -- Common types for dependency resolution. ----------------------------------------------------------------------------- module Distribution.Client.Dependency.Types (-    PackageName,     DependencyResolver, -    PackagePreference(..),-    PackageVersionPreference,-    PackageInstalledPreference(..),+    PackageConstraint(..),+    PackagePreferences(..),+    InstalledPreference(..),      Progress(..),     foldProgress,   ) where  import Distribution.Client.Types-         ( UnresolvedDependency(..), AvailablePackage(..) )+         ( AvailablePackage(..) ) import qualified Distribution.Client.InstallPlan as InstallPlan  import Distribution.InstalledPackageInfo          ( InstalledPackageInfo )+import Distribution.PackageDescription+         ( FlagAssignment ) import Distribution.Simple.PackageIndex          ( PackageIndex ) import Distribution.Package@@ -37,7 +38,7 @@ import Distribution.Compiler          ( CompilerId ) import Distribution.System-         ( OS, Arch )+         ( Platform )  import Prelude hiding (fail) @@ -49,18 +50,28 @@ -- solving the package dependency problem and we want to make it easy to swap -- in alternatives. ---type DependencyResolver = OS-                       -> Arch+type DependencyResolver = Platform                        -> CompilerId                        -> PackageIndex InstalledPackageInfo                        -> PackageIndex AvailablePackage-                       -> (PackageName -> PackagePreference)-                       -> [UnresolvedDependency]+                       -> (PackageName -> PackagePreferences)+                       -> [PackageConstraint]+                       -> [PackageName]                        -> Progress String String [InstallPlan.PlanPackage] +-- | Per-package constraints. Package constraints must be respected by the+-- solver. Multiple constraints for each package can be given, though obviously+-- it is possible to construct conflicting constraints (eg impossible version+-- range or inconsistent flag assignment).+--+data PackageConstraint+   = PackageVersionConstraint   PackageName VersionRange+   | PackageInstalledConstraint PackageName+   | PackageFlagsConstraint     PackageName FlagAssignment+ -- | A per-package preference on the version. It is a soft constraint that the -- 'DependencyResolver' should try to respect where possible. It consists of--- a 'PackageInstalledPreference' which says if we prefer versions of packages+-- a 'InstalledPreference' which says if we prefer versions of packages -- that are already installed. It also hase a 'PackageVersionPreference' which -- is a suggested constraint on the version number. The resolver should try to -- use package versions that satisfy the suggested version constraint.@@ -68,19 +79,12 @@ -- It is not specified if preferences on some packages are more important than -- others. ---data PackagePreference = PackagePreference-       PackageInstalledPreference-       PackageVersionPreference---- | A suggested constraint on the version number. The resolver should try to--- use package versions that satisfy the suggested version constraint.----type PackageVersionPreference = VersionRange+data PackagePreferences = PackagePreferences VersionRange InstalledPreference  -- | Wether we prefer an installed version of a package or simply the latest -- version. ---data PackageInstalledPreference = PreferInstalled | PreferLatest+data InstalledPreference = PreferInstalled | PreferLatest  -- | A type to represent the unfolding of an expensive long running -- calculation that may fail. We may get intermediate steps before the final

Distribution/Client/Fetch.hs view

@@ -26,14 +26,18 @@          , AvailablePackageSource(..), AvailablePackageDb(..)          , Repo(..), RemoteRepo(..), LocalRepo(..) ) import Distribution.Client.Dependency-         ( resolveDependenciesWithProgress, packagesPreference-         , PackagesInstalledPreference(..) )+         ( resolveDependenciesWithProgress+         , dependencyConstraints, dependencyTargets+         , PackagesPreference(..), PackagesPreferenceDefault(..)+         , PackagePreference(..) ) import Distribution.Client.Dependency.Types          ( foldProgress ) import Distribution.Client.IndexUtils as IndexUtils          ( getAvailablePackages, disambiguateDependencies ) import qualified Distribution.Client.InstallPlan as InstallPlan import Distribution.Client.HttpUtils (getHTTP, isOldHackageURI)+import Distribution.Client.Utils+         ( writeFileAtomic )  import Distribution.Package          ( PackageIdentifier, packageName, packageVersion, Dependency(..) )@@ -46,14 +50,15 @@          ( getInstalledPackages ) import Distribution.Simple.Utils          ( die, notice, info, debug, setupMessage-         , copyFileVerbose, writeFileAtomic )+         , copyFileVerbose ) import Distribution.System-         ( buildOS, buildArch )+         ( buildPlatform ) import Distribution.Text          ( display ) import Distribution.Verbosity          ( Verbosity ) +import qualified Data.Map as Map import Control.Monad          ( when, filterM ) import System.Directory@@ -65,7 +70,9 @@ import Network.URI          ( URI(uriPath, uriScheme) ) import Network.HTTP-         ( ConnError(..), Response(..) )+         ( Response(..) )+import Network.Stream+         ( ConnError(..) )   downloadURI :: Verbosity@@ -81,7 +88,8 @@     Left err -> return (Just err)     Right rsp       | rspCode rsp == (2,0,0)-     -> writeFileAtomic path (rspBody rsp)+     -> do info verbosity ("Downloaded to " ++ path)+           writeFileAtomic path (rspBody rsp)      --FIXME: check the content-length header matches the body length.      --TODO: stream the download into the file rather than buffering the whole      --      thing in memory.@@ -113,7 +121,7 @@ downloadIndex verbosity repo cacheDir = do   let uri = (remoteRepoURI repo) {               uriPath = uriPath (remoteRepoURI repo)-	                  `FilePath.Posix.combine` "00-index.tar.gz"+                          `FilePath.Posix.combine` "00-index.tar.gz"             }       path = cacheDir </> "00-index" <.> "tar.gz"   createDirectoryIfMissing True cacheDir@@ -133,7 +141,7 @@ fetchPackage verbosity repo pkgid = do   fetched <- doesFileExist (packageFile repo pkgid)   if fetched-    then do notice verbosity $ "'" ++ display pkgid ++ "' is cached."+    then do info verbosity $ display pkgid ++ " has already been downloaded."             return (packageFile repo pkgid)     else do setupMessage verbosity "Downloading" pkgid             downloadPackage verbosity repo pkgid@@ -148,7 +156,7 @@       -> IO () fetch verbosity packageDB repos comp conf deps = do   installed <- getInstalledPackages verbosity comp packageDB conf-  AvailablePackageDb available versionPref+  AvailablePackageDb available availablePrefs             <- getAvailablePackages verbosity repos   deps' <- IndexUtils.disambiguateDependencies available deps @@ -162,10 +170,13 @@           [ name | UnresolvedDependency (Dependency name _) _ <- pkgs ]    let  progress = resolveDependenciesWithProgress-                   buildOS buildArch (compilerId comp)+                   buildPlatform (compilerId comp)                    installed' available-                   (packagesPreference PreferLatestForSelected versionPref)-                   deps'+                   (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

Distribution/Client/HttpUtils.hs view

@@ -14,7 +14,9 @@          ( Proxy (..), Authority (..), browse          , setOutHandler, setErrHandler, setProxy, request) import Control.Monad-         ( mplus, join )+         ( mplus, join, liftM2 )+import qualified Data.ByteString.Lazy as ByteString+import Data.ByteString.Lazy (ByteString) #ifdef WIN32 import System.Win32.Types          ( DWORD, HKEY )@@ -25,9 +27,8 @@          ( handle, bracket ) import Foreign          ( toBool, Storable(peek, sizeOf), castPtr, alloca )-#else-import System.Environment (getEnvironment) #endif+import System.Environment (getEnvironment)  import qualified Paths_cabal_install (version) import Distribution.Verbosity (Verbosity)@@ -42,10 +43,10 @@ -- proxy settings hiding all this system-dependent stuff below.  -- try to read the system proxy settings on windows or unix-proxyString :: IO (Maybe String)+proxyString, envProxyString, registryProxyString :: IO (Maybe String) #ifdef WIN32 -- read proxy settings from the windows registry-proxyString = handle (\_ -> return Nothing) $+registryProxyString = handle (\_ -> return Nothing) $   bracket (regOpenKey hive path) regCloseKey $ \hkey -> do     enable <- fmap toBool $ regQueryValueDWORD hkey "ProxyEnable"     if enable@@ -65,12 +66,17 @@       regQueryValueEx hkey name (castPtr ptr) (sizeOf (undefined :: DWORD))       peek ptr #else+registryProxyString = return Nothing+#endif+ -- read proxy settings by looking for an env var-proxyString = do+envProxyString = do   env <- getEnvironment   return (lookup "http_proxy" env `mplus` lookup "HTTP_PROXY" env)-#endif +proxyString = liftM2 mplus envProxyString registryProxyString++ -- |Get the local proxy settings   proxy :: Verbosity -> IO Proxy proxy verbosity = do@@ -101,9 +107,17 @@   where     parseHttpURI str' = case parseAbsoluteURI str' of       Just uri@URI { uriAuthority = Just _ }-         -> Just uri+         -> Just (fixUserInfo uri)       _  -> Nothing +fixUserInfo :: URI -> URI+fixUserInfo uri = uri{ uriAuthority = f `fmap` uriAuthority uri }+    where+      f a@URIAuth{ uriUserInfo = s } =+          a{ uriUserInfo = case reverse s of+                             '@':s' -> reverse s'+                             _      -> s+           } uri2proxy :: URI -> Maybe Proxy uri2proxy uri@URI{ uriScheme = "http:"                  , uriAuthority = Just (URIAuth auth' host port)@@ -117,15 +131,15 @@                        _      -> pwd' uri2proxy _ = Nothing -mkRequest :: URI -> Request+mkRequest :: URI -> Request ByteString mkRequest uri = Request{ rqURI     = uri                        , rqMethod  = GET                        , rqHeaders = [Header HdrUserAgent userAgent]-                       , rqBody    = "" }+                       , rqBody    = ByteString.empty }   where userAgent = "cabal-install/" ++ display Paths_cabal_install.version  -- |Carry out a GET request, using the local proxy settings-getHTTP :: Verbosity -> URI -> IO (Result Response)+getHTTP :: Verbosity -> URI -> IO (Result (Response ByteString)) getHTTP verbosity uri = do                  p   <- proxy verbosity                  let req = mkRequest uri

Distribution/Client/IndexUtils.hs view

@@ -48,7 +48,7 @@ import Data.List   (isPrefixOf) import Data.Monoid (Monoid(..)) import qualified Data.Map as Map-import Control.Monad (MonadPlus(mplus))+import Control.Monad (MonadPlus(mplus), when) import Control.Exception (evaluate) import qualified Data.ByteString.Lazy as BS import qualified Data.ByteString.Lazy.Char8 as BS.Char8@@ -58,6 +58,10 @@ import System.FilePath.Posix as FilePath.Posix          ( takeFileName ) import System.IO.Error (isDoesNotExistError)+import System.Directory+         ( getModificationTime )+import System.Time+         ( getClockTime, diffClockTimes, normalizeTimeDiff, TimeDiff(tdDay) )  -- | Read a repository index from disk, from the local files specified by -- a list of 'Repo's.@@ -68,6 +72,13 @@ -- This is a higher level wrapper used internally in cabal-install. -- getAvailablePackages :: Verbosity -> [Repo] -> IO AvailablePackageDb+getAvailablePackages verbosity [] = do+  warn verbosity $ "No remote package servers have been specified. Usually "+                ++ "you would have one specified in the config file."+  return AvailablePackageDb {+    packageIndex       = mempty,+    packagePreferences = mempty+  } getAvailablePackages verbosity repos = do   info verbosity "Reading available packages..."   pkgss <- mapM (readRepoIndex verbosity) repos@@ -104,6 +115,7 @@       }     | (pkgid, pkg) <- pkgs] +  warnIfIndexIsOld indexFile   return (pkgIndex, prefs)    where@@ -129,6 +141,18 @@             ++ "' is missing. The repo is invalid."         return mempty       else ioError e++    isOldThreshold = 15 --days+    warnIfIndexIsOld indexFile = do+      indexTime   <- getModificationTime indexFile+      currentTime <- getClockTime+      let diff = normalizeTimeDiff (diffClockTimes currentTime indexTime)+      when (tdDay diff >= isOldThreshold) $ case repoKind repo of+        Left  remoteRepo -> warn verbosity $+             "The package list for '" ++ remoteRepoName remoteRepo+          ++ "' is " ++ show (tdDay diff)  ++ " days old.\nRun "+          ++ "'cabal update' to get the latest list of available packages."+        Right _localRepo -> return ()  parsePreferredVersions :: String -> [Dependency] parsePreferredVersions = catMaybes

Distribution/Client/Install.hs view

@@ -19,6 +19,7 @@          ( unfoldr, find, nub, sort ) import Data.Maybe          ( isJust, fromMaybe )+import qualified Data.Map as Map import Control.Exception as Exception          ( handle, handleJust, Exception(IOException) ) import Control.Monad@@ -34,9 +35,11 @@  import Distribution.Client.Dependency          ( resolveDependenciesWithProgress-         , packagesPreference, PackagesInstalledPreference(..)-         , upgradableDependencies )-import Distribution.Client.Dependency.Types (Progress(..), foldProgress)+         , PackageConstraint(..), dependencyConstraints, dependencyTargets+         , PackagesPreference(..), PackagesPreferenceDefault(..)+         , PackagePreference(..)+         , upgradableDependencies+         , Progress(..), foldProgress, ) import Distribution.Client.Fetch (fetchPackage) -- import qualified Distribution.Client.Info as Info import Distribution.Client.IndexUtils as IndexUtils@@ -44,7 +47,8 @@ import qualified Distribution.Client.InstallPlan as InstallPlan import Distribution.Client.InstallPlan (InstallPlan) import Distribution.Client.Setup-         ( InstallFlags(..), configureCommand, filterConfigureFlags )+         ( ConfigFlags(..), configureCommand, filterConfigureFlags+         , ConfigExFlags(..), InstallFlags(..) ) import Distribution.Client.Config          ( defaultLogsDir, defaultCabalDir ) import Distribution.Client.Tar (extractTarGzFile)@@ -54,6 +58,8 @@          , Repo(..), ConfiguredPackage(..)          , BuildResult, BuildFailure(..), BuildSuccess(..)          , DocsResult(..), TestsResult(..), RemoteRepo(..) )+import Distribution.Client.BuildReports.Types+         ( ReportLevel(..) ) import Distribution.Client.SetupWrapper          ( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions ) import qualified Distribution.Client.BuildReports.Anonymous as BuildReports@@ -69,18 +75,21 @@ import Distribution.Simple.Program (ProgramConfiguration, defaultProgramConfiguration) import Distribution.Simple.Configure (getInstalledPackages) import qualified Distribution.Simple.InstallDirs as InstallDirs-import qualified Distribution.Simple.Setup as Cabal import qualified Distribution.Simple.PackageIndex as PackageIndex import Distribution.Simple.PackageIndex (PackageIndex) import Distribution.Simple.Setup-         ( flagToMaybe )+         ( haddockCommand, HaddockFlags(..), emptyHaddockFlags+         , buildCommand, BuildFlags(..), emptyBuildFlags+         , toFlag, fromFlag, fromFlagOrDefault, flagToMaybe )+import qualified Distribution.Simple.Setup as Cabal+         ( installCommand, InstallFlags(..), emptyInstallFlags ) import Distribution.Simple.Utils-         ( defaultPackageDesc, rawSystemExit, withTempDirectory, comparing )+         ( defaultPackageDesc, rawSystemExit, comparing ) import Distribution.Simple.InstallDirs-         ( fromPathTemplate, toPathTemplate+         ( PathTemplate, fromPathTemplate, toPathTemplate          , initialPathTemplateEnv, substPathTemplate ) import Distribution.Package-         ( PackageIdentifier, packageName, packageVersion+         ( PackageName, PackageIdentifier, packageName, packageVersion          , Package(..), PackageFixedDeps(..)          , Dependency(..), thisPackageVersion ) import qualified Distribution.PackageDescription as PackageDescription@@ -97,9 +106,9 @@ import Distribution.Simple.Utils as Utils          ( notice, info, warn, die, intercalate ) import Distribution.Client.Utils-         ( inDir, mergeBy, MergeResult(..) )+         ( inDir, mergeBy, MergeResult(..), withTempDirectory ) import Distribution.System-         ( OS(Windows), buildOS, Arch, buildArch )+         ( Platform(Platform), buildPlatform, OS(Windows), buildOS ) import Distribution.Text          ( display ) import Distribution.Verbosity as Verbosity@@ -118,27 +127,36 @@   -> [Repo]   -> Compiler   -> ProgramConfiguration-  -> Cabal.ConfigFlags+  -> ConfigFlags+  -> ConfigExFlags   -> InstallFlags   -> [UnresolvedDependency]   -> IO ()-install verbosity packageDB repos comp conf configFlags installFlags deps =+install verbosity packageDB repos comp conf+  configFlags configExFlags installFlags deps =+   installWithPlanner planner-        verbosity packageDB repos comp conf configFlags installFlags+        verbosity packageDB repos comp conf+        configFlags configExFlags installFlags   where     planner :: Planner-    planner | null deps = planLocalPackage verbosity comp configFlags+    planner | null deps = planLocalPackage verbosity+                            comp configFlags configExFlags             | otherwise = planRepoPackages PreferLatestForSelected-                            comp installFlags deps+                            comp configFlags configExFlags installFlags deps -upgrade verbosity packageDB repos comp conf configFlags installFlags deps =+upgrade verbosity packageDB repos comp conf+  configFlags configExFlags installFlags deps =+   installWithPlanner planner-        verbosity packageDB repos comp conf configFlags installFlags+        verbosity packageDB repos comp conf+        configFlags configExFlags installFlags   where     planner :: Planner-    planner | null deps = planUpgradePackages comp+    planner | null deps = planUpgradePackages+                            comp configFlags configExFlags             | otherwise = planRepoPackages PreferAllLatest-                            comp installFlags deps+                            comp configFlags configExFlags installFlags deps  type Planner = Maybe (PackageIndex InstalledPackageInfo)             -> AvailablePackageDb@@ -152,10 +170,13 @@         -> [Repo]         -> Compiler         -> ProgramConfiguration-        -> Cabal.ConfigFlags+        -> ConfigFlags+        -> ConfigExFlags         -> InstallFlags         -> IO ()-installWithPlanner planner verbosity packageDB repos comp conf configFlags installFlags = do+installWithPlanner planner verbosity packageDB repos comp conf+  configFlags configExFlags installFlags = do+   installed <- getInstalledPackages verbosity comp packageDB conf   available <- getAvailablePackages verbosity repos @@ -179,23 +200,25 @@        unless dryRun $ do         logsDir <- defaultLogsDir-        let os     = InstallPlan.planOS installPlan-            arch   = InstallPlan.planArch installPlan-            compid = InstallPlan.planCompiler installPlan+        let platform = InstallPlan.planPlatform installPlan+            compid   = InstallPlan.planCompiler installPlan         installPlan' <-           executeInstallPlan installPlan $ \cpkg ->-            installConfiguredPackage os arch compid configFlags+            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) +        -- build reporting, local and remote         let buildReports = BuildReports.fromInstallPlan installPlan'-        BuildReports.storeAnonymous buildReports-        BuildReports.storeLocal     buildReports-        when useDetailedBuildReports $+        BuildReports.storeLocal (installSummaryFile installFlags) buildReports+        when (reportingLevel >= AnonymousReports) $+          BuildReports.storeAnonymous buildReports+        when (reportingLevel == DetailedReports) $           storeDetailedBuildReports verbosity logsDir buildReports+         symlinkBinaries verbosity configFlags installFlags installPlan'         printBuildFailures installPlan' @@ -203,32 +226,42 @@     setupScriptOptions index = SetupScriptOptions {       useCabalVersion  = maybe AnyVersion ThisVersion (libVersion miscOptions),       useCompiler      = Just comp,-      usePackageIndex  = if packageDB == UserPackageDB then index else Nothing,+      -- 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.+      -- TODO: if we specify a specific db then we do not look in the user+      --       package db but we probably should ie [global, user, specific]+      usePackageDB     = if packageDB == GlobalPackageDB then UserPackageDB+                                                         else packageDB,+      usePackageIndex  = if packageDB == GlobalPackageDB then Nothing+                                                         else index,       useProgramConfig = conf,-      useDistPref      = Cabal.fromFlagOrDefault+      useDistPref      = fromFlagOrDefault                            (useDistPref defaultSetupScriptOptions)-                           (Cabal.configDistPref configFlags),+                           (configDistPref configFlags),       useLoggingHandle = Nothing,       useWorkingDir    = Nothing     }-    useDetailedBuildReports = Cabal.fromFlagOrDefault False (installBuildReports installFlags)+    reportingLevel = fromFlagOrDefault NoReports (installBuildReports installFlags)     useLogFile :: FilePath -> Maybe (PackageIdentifier -> FilePath)     useLogFile logsDir = fmap substLogFileName logFileTemplate       where-        logFileTemplate-          | useDetailedBuildReports = Just $ logsDir </> "$pkgid" <.> "log"-          | otherwise = Cabal.flagToMaybe (installLogFile installFlags)-    substLogFileName path pkg = fromPathTemplate-                              . substPathTemplate env-                              . toPathTemplate-                              $ path+        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       = Cabal.fromFlagOrDefault False (installDryRun installFlags)+    dryRun       = fromFlagOrDefault False (installDryRun installFlags)     miscOptions  = InstallMisc {-      rootCmd    = if Cabal.fromFlag (Cabal.configUserInstall configFlags)+      rootCmd    = if fromFlag (configUserInstall configFlags)                      then Nothing      -- ignore --root-cmd if --user.-                     else Cabal.flagToMaybe (installRootCmd installFlags),-      libVersion = Cabal.flagToMaybe (installCabalVersion installFlags)+                     else flagToMaybe (installRootCmd installFlags),+      libVersion = flagToMaybe (configCabalVersion configExFlags)     }  storeDetailedBuildReports :: Verbosity -> FilePath@@ -266,9 +299,10 @@ -- | Make an 'InstallPlan' for the unpacked package in the current directory, -- and all its dependencies. ---planLocalPackage :: Verbosity -> Compiler -> Cabal.ConfigFlags -> Planner-planLocalPackage verbosity comp configFlags installed-  (AvailablePackageDb available versionPrefs) = do+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@@ -281,49 +315,87 @@         Available.packageDescription = pkg,         packageSource                = LocalUnpackedPackage       }-      localPkgDep = UnresolvedDependency {-        dependency = thisPackageVersion (packageId localPkg),-        depFlags   = Cabal.configConfigurationsFlags configFlags-      }+      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 buildOS buildArch (compilerId comp)-             installed' available'-             (packagesPreference PreferLatestForSelected versionPrefs)-             [localPkgDep]+  return $ resolveDependenciesWithProgress buildPlatform (compilerId comp)+             installed' available' preferences constraints targets  -- | Make an 'InstallPlan' for the given dependencies. ---planRepoPackages :: PackagesInstalledPreference -> Compiler -> InstallFlags+planRepoPackages :: PackagesPreferenceDefault -> Compiler+                 -> ConfigFlags -> ConfigExFlags -> InstallFlags                  -> [UnresolvedDependency] -> Planner-planRepoPackages installedPref comp installFlags deps installed-  (AvailablePackageDb available versionPrefs) = do+planRepoPackages defaultPref comp configFlags configExFlags installFlags+  deps installed (AvailablePackageDb available availablePrefs) = do+   deps' <- IndexUtils.disambiguateDependencies available deps   let installed'-        | Cabal.fromFlagOrDefault False (installReinstall installFlags)+        | fromFlagOrDefault False (installReinstall installFlags)                     = fmap (hideGivenDeps deps') installed         | otherwise = installed-  return $ resolveDependenciesWithProgress buildOS buildArch (compilerId comp)-             installed' available-             (packagesPreference installedPref versionPrefs)-             deps'+      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 -> Planner-planUpgradePackages comp (Just installed)-  (AvailablePackageDb available versionPrefs) = return $-  resolveDependenciesWithProgress buildOS buildArch (compilerId comp)-    (Just installed) available-    (packagesPreference PreferAllLatest versionPrefs)-    [ UnresolvedDependency dep []-    | dep <- upgradableDependencies installed available ]-planUpgradePackages comp _ _ =+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 InstalledPackageInfo)             -> InstallPlan -> IO () printDryRun verbosity minstalled plan = case unfoldr next plan of@@ -367,7 +439,7 @@     changed _                        = True  symlinkBinaries :: Verbosity-                -> Cabal.ConfigFlags+                -> ConfigFlags                 -> InstallFlags                 -> InstallPlan -> IO () symlinkBinaries verbosity configFlags installFlags plan = do@@ -390,7 +462,7 @@         ++ "manually if you wish. The executable files have been installed at "         ++ intercalate ", " [ path | (_, _, path) <- exes ]   where-    bindir = Cabal.fromFlag (installSymlinkBinDir installFlags)+    bindir = fromFlag (installSymlinkBinDir installFlags)  printBuildFailures :: InstallPlan -> IO () printBuildFailures plan =@@ -443,16 +515,16 @@ -- versioned package dependencies. So we ignore any previous partial flag -- assignment or dependency constraints and use the new ones. ---installConfiguredPackage :: OS -> Arch -> CompilerId-                         ->  Cabal.ConfigFlags -> ConfiguredPackage-                         -> (Cabal.ConfigFlags -> AvailablePackageSource-                                               -> PackageDescription -> a)+installConfiguredPackage :: Platform -> CompilerId+                         ->  ConfigFlags -> ConfiguredPackage+                         -> (ConfigFlags -> AvailablePackageSource+                                         -> PackageDescription -> a)                          -> a-installConfiguredPackage os arch comp configFlags+installConfiguredPackage (Platform arch os) comp configFlags   (ConfiguredPackage (AvailablePackage _ gpkg source) flags deps)   installPkg = installPkg configFlags {-    Cabal.configConfigurationsFlags = flags,-    Cabal.configConstraints = map thisPackageVersion deps+    configConfigurationsFlags = flags,+    configConstraints = map thisPackageVersion deps   } source pkg   where     pkg = case finalizePackageDescription flags@@ -471,24 +543,24 @@ installAvailablePackage verbosity pkgid (RepoTarballPackage repo) installPkg =   onFailure DownloadFailed $ do     pkgPath <- fetchPackage verbosity repo pkgid-    tmp <- getTemporaryDirectory-    let tmpDirPath = tmp </> ("TMP" ++ display pkgid)-        path = tmpDirPath </> display pkgid-    onFailure UnpackFailed $ withTempDirectory verbosity tmpDirPath $ do-      info verbosity $ "Extracting " ++ pkgPath-                    ++ " to " ++ tmpDirPath ++ "..."-      extractTarGzFile tmpDirPath pkgPath-      let descFilePath = tmpDirPath </> display pkgid-                                    </> display (packageName pkgid) <.> "cabal"-      exists <- doesFileExist descFilePath-      when (not exists) $-        die $ "Package .cabal file not found: " ++ show descFilePath-      installPkg (Just path)+    onFailure UnpackFailed $ do+      tmp <- getTemporaryDirectory+      withTempDirectory tmp (display pkgid) $ \tmpDirPath -> do+        info verbosity $ "Extracting " ++ pkgPath+                      ++ " to " ++ tmpDirPath ++ "..."+        extractTarGzFile tmpDirPath pkgPath+        let unpackedPath = tmpDirPath </> display pkgid+            descFilePath = unpackedPath+                       </> display (packageName pkgid) <.> "cabal"+        exists <- doesFileExist descFilePath+        when (not exists) $+          die $ "Package .cabal file not found: " ++ show descFilePath+        installPkg (Just unpackedPath)  installUnpackedPackage :: Verbosity                    -> SetupScriptOptions                    -> InstallMisc-                   -> Cabal.ConfigFlags+                   -> ConfigFlags                    -> InstallFlags                    -> CompilerId                    -> PackageDescription@@ -505,12 +577,12 @@    -- Build phase     onFailure BuildFailed $ do-      setup buildCommand buildFlags+      setup buildCommand' buildFlags    -- Doc generation phase       docsResult <- if shouldHaddock         then Exception.handle (\_ -> return DocsFailed) $ do-               setup Cabal.haddockCommand haddockFlags+               setup haddockCommand haddockFlags                return DocsOk         else return DocsNotTried @@ -527,22 +599,22 @@    where     configureFlags   = filterConfigureFlags configFlags {-      Cabal.configVerbosity = Cabal.toFlag verbosity'+      configVerbosity = toFlag verbosity'     } -    buildCommand     = Cabal.buildCommand defaultProgramConfiguration-    buildFlags   _   = Cabal.emptyBuildFlags {-      Cabal.buildDistPref  = Cabal.configDistPref configFlags,-      Cabal.buildVerbosity = Cabal.toFlag verbosity'+    buildCommand'    = buildCommand defaultProgramConfiguration+    buildFlags   _   = emptyBuildFlags {+      buildDistPref  = configDistPref configFlags,+      buildVerbosity = toFlag verbosity'     }-    shouldHaddock    = Cabal.fromFlagOrDefault False+    shouldHaddock    = fromFlagOrDefault False                          (installDocumentation installConfigFlags)-    haddockFlags _   = Cabal.emptyHaddockFlags {-      Cabal.haddockDistPref  = Cabal.configDistPref configFlags,-      Cabal.haddockVerbosity = Cabal.toFlag verbosity'+    haddockFlags _   = emptyHaddockFlags {+      haddockDistPref  = configDistPref configFlags,+      haddockVerbosity = toFlag verbosity'     }     installFlags _   = Cabal.emptyInstallFlags {-      Cabal.installDistPref  = Cabal.configDistPref configFlags,-      Cabal.installVerbosity = Cabal.toFlag verbosity'+      Cabal.installDistPref  = configDistPref configFlags,+      Cabal.installVerbosity = toFlag verbosity'     }     verbosity' | isJust useLogFile = max Verbosity.verbose verbosity                | otherwise         = verbosity@@ -550,11 +622,11 @@       logFileHandle <- case useLogFile of         Nothing          -> return Nothing         Just mkLogFileName -> do-	  let logFileName = mkLogFileName (packageId pkg)-	      logDir      = takeDirectory logFileName-	  unless (null logDir) $ createDirectoryIfMissing True logDir-	  logFile <- openFile logFileName AppendMode-	  return (Just logFile)+          let logFileName = mkLogFileName (packageId pkg)+              logDir      = takeDirectory logFileName+          unless (null logDir) $ createDirectoryIfMissing True logDir+          logFile <- openFile logFileName AppendMode+          return (Just logFile)        setupWrapper verbosity         scriptOptions { useLoggingHandle = logFileHandle@@ -580,7 +652,7 @@   withWin32SelfUpgrade :: Verbosity-                     -> Cabal.ConfigFlags+                     -> ConfigFlags                      -> CompilerId                      -> PackageDescription                      -> IO a -> IO a@@ -589,7 +661,7 @@    defaultDirs <- InstallDirs.defaultInstallDirs                    compilerFlavor-                   (Cabal.fromFlag (Cabal.configUserInstall configFlags))+                   (fromFlag (configUserInstall configFlags))                    (PackageDescription.hasLibs pkg)    Win32SelfUpgrade.possibleSelfUpgrade verbosity@@ -607,11 +679,11 @@             prefix  = substTemplate prefixTemplate             suffix  = substTemplate suffixTemplate ]       where-        fromFlagTemplate = Cabal.fromFlagOrDefault (InstallDirs.toPathTemplate "")-        prefixTemplate = fromFlagTemplate (Cabal.configProgPrefix configFlags)-        suffixTemplate = fromFlagTemplate (Cabal.configProgSuffix configFlags)-        templateDirs   = InstallDirs.combineInstallDirs Cabal.fromFlagOrDefault-                           defaultDirs (Cabal.configInstallDirs configFlags)+        fromFlagTemplate = fromFlagOrDefault (InstallDirs.toPathTemplate "")+        prefixTemplate = fromFlagTemplate (configProgPrefix configFlags)+        suffixTemplate = fromFlagTemplate (configProgSuffix configFlags)+        templateDirs   = InstallDirs.combineInstallDirs fromFlagOrDefault+                           defaultDirs (configInstallDirs configFlags)         absoluteDirs   = InstallDirs.absoluteInstallDirs                            pkgid compid InstallDirs.NoCopyDest templateDirs         substTemplate  = InstallDirs.fromPathTemplate

Distribution/Client/InstallPlan.hs view

@@ -24,8 +24,7 @@   failed,    -- ** Query functions-  planOS,-  planArch,+  planPlatform,   planCompiler,    -- * Checking valididy of plans@@ -66,7 +65,7 @@ import Distribution.Text          ( display ) import Distribution.System-         ( OS, Arch )+         ( Platform(Platform) ) import Distribution.Compiler          ( CompilerId(..) ) import Distribution.Client.Utils@@ -148,32 +147,30 @@     planGraphRev :: Graph,     planPkgOf    :: Graph.Vertex -> PlanPackage,     planVertexOf :: PackageIdentifier -> Graph.Vertex,-    planOS       :: OS,-    planArch     :: Arch,+    planPlatform :: Platform,     planCompiler :: CompilerId   }  invariant :: InstallPlan -> Bool invariant plan =-  valid (planOS plan) (planArch plan) (planCompiler plan) (planIndex plan)+  valid (planPlatform plan) (planCompiler plan) (planIndex plan)  internalError :: String -> a internalError msg = error $ "InstallPlan: internal error: " ++ msg  -- | Build an installation plan from a valid set of resolved packages. ---new :: OS -> Arch -> CompilerId -> PackageIndex PlanPackage+new :: Platform -> CompilerId -> PackageIndex PlanPackage     -> Either [PlanProblem] InstallPlan-new os arch compiler index =-  case problems os arch compiler index of+new platform compiler index =+  case problems platform compiler index of     [] -> Right InstallPlan {             planIndex    = index,             planGraph    = graph,             planGraphRev = Graph.transposeG graph,             planPkgOf    = vertexToPkgId,             planVertexOf = fromMaybe noSuchPkgId . pkgIdToVertex,-            planOS       = os,-            planArch     = arch,+            planPlatform = platform,             planCompiler = compiler           }       where (graph, vertexToPkgId, pkgIdToVertex) =@@ -279,8 +276,8 @@ -- -- * if the result is @False@ use 'problems' to get a detailed list. ---valid :: OS -> Arch -> CompilerId -> PackageIndex PlanPackage -> Bool-valid os arch comp index = null (problems os arch comp index)+valid :: Platform -> CompilerId -> PackageIndex PlanPackage -> Bool+valid platform comp index = null (problems platform comp index)  data PlanProblem =      PackageInvalid       ConfiguredPackage [PackageProblem]@@ -329,12 +326,12 @@ -- error messages. This is mainly intended for debugging purposes. -- Use 'showPlanProblem' for a human readable explanation. ---problems :: OS -> Arch -> CompilerId+problems :: Platform -> CompilerId          -> PackageIndex PlanPackage -> [PlanProblem]-problems os arch comp index =+problems platform comp index =      [ PackageInvalid pkg packageProblems      | Configured pkg <- PackageIndex.allPackages index-     , let packageProblems = configuredPackageProblems os arch comp pkg+     , let packageProblems = configuredPackageProblems platform comp pkg      , not (null packageProblems) ]    ++ [ PackageMissingDeps pkg missingDeps@@ -416,9 +413,9 @@ -- in the configuration given by the flag assignment, all the package -- dependencies are satisfied by the specified packages. ---configuredPackageValid :: OS -> Arch -> CompilerId -> ConfiguredPackage -> Bool-configuredPackageValid os arch comp pkg =-  null (configuredPackageProblems os arch comp pkg)+configuredPackageValid :: Platform -> CompilerId -> ConfiguredPackage -> Bool+configuredPackageValid platform comp pkg =+  null (configuredPackageProblems platform comp pkg)  data PackageProblem = DuplicateFlag FlagName                     | MissingFlag   FlagName@@ -456,9 +453,9 @@   ++ " but the configuration specifies " ++ display pkgid   ++ " which does not satisfy the dependency." -configuredPackageProblems :: OS -> Arch -> CompilerId+configuredPackageProblems :: Platform -> CompilerId                           -> ConfiguredPackage -> [PackageProblem]-configuredPackageProblems os arch comp+configuredPackageProblems (Platform arch os) comp   (ConfiguredPackage pkg specifiedFlags specifiedDeps) =      [ DuplicateFlag flag | ((flag,_):_) <- duplicates specifiedFlags ]   ++ [ MissingFlag flag | OnlyInLeft  flag <- mergedFlags ]

Distribution/Client/InstallSymlink.hs view

@@ -59,6 +59,8 @@          ( ConfigFlags(..), fromFlag, fromFlagOrDefault, flagToMaybe ) import qualified Distribution.Simple.InstallDirs as InstallDirs import Distribution.Simple.PackageIndex (PackageIndex)+import Distribution.System+         ( Platform(Platform) )  import System.Posix.Files          ( getSymbolicLinkStatus, isSymbolicLink, readSymbolicLink@@ -160,8 +162,7 @@     fromFlagTemplate = fromFlagOrDefault (InstallDirs.toPathTemplate "")     prefixTemplate   = fromFlagTemplate (configProgPrefix configFlags)     suffixTemplate   = fromFlagTemplate (configProgSuffix configFlags)-    os   = InstallPlan.planOS plan-    arch = InstallPlan.planArch plan+    (Platform arch os) = InstallPlan.planPlatform plan     compilerId@(CompilerId compilerFlavor _) = InstallPlan.planCompiler plan  symlinkBinary :: FilePath -- ^ The canonical path of the public bin dir

Distribution/Client/List.hs view

@@ -1,50 +1,67 @@ ----------------------------------------------------------------------------- -- |--- Module      :  Distribution.Client.Install+-- Module      :  Distribution.Client.List -- Copyright   :  (c) David Himmelstrup 2005+--                    Duncan Coutts 2008-2009 -- License     :  BSD-like ----- Maintainer  :  lemmih@gmail.com--- Stability   :  provisional--- Portability :  portable+-- Maintainer  :  cabal-devel@haskell.org ----- High level interface to package installation.+-- Search for and print information about packages ----------------------------------------------------------------------------- module Distribution.Client.List (-  list+  list, info   ) where -import Data.List (sortBy, groupBy, sort, nub, intersperse)-import Data.Maybe (listToMaybe, fromJust)-import Control.Monad (MonadPlus(mplus))-import Control.Exception (assert)--import Text.PrettyPrint.HughesPJ-import Distribution.Text-         ( Text(disp), display )- import Distribution.Package-         ( PackageIdentifier(..), PackageName(..), Package(..) )+         ( PackageName(..), packageName, packageVersion+         , Dependency(..), thisPackageVersion )+import Distribution.ModuleName (ModuleName) import Distribution.License (License)-import qualified Distribution.PackageDescription as Available import Distribution.InstalledPackageInfo (InstalledPackageInfo) import qualified Distribution.InstalledPackageInfo as Installed-import qualified Distribution.Simple.PackageIndex as PackageIndex-import Distribution.Version (Version)-import Distribution.Verbosity (Verbosity)+import qualified Distribution.PackageDescription   as Available+import Distribution.PackageDescription+         ( Flag(..), FlagName(..) )+import Distribution.PackageDescription.Configuration+         ( flattenPackageDescription ) -import Distribution.Client.IndexUtils (getAvailablePackages)-import Distribution.Client.Setup (ListFlags(..))-import Distribution.Client.Types-         ( AvailablePackage(..), Repo, AvailablePackageDb(..) ) import Distribution.Simple.Configure (getInstalledPackages) import Distribution.Simple.Compiler (Compiler,PackageDB) import Distribution.Simple.Program (ProgramConfiguration) import Distribution.Simple.Utils (equating, comparing, notice) import Distribution.Simple.Setup (fromFlag)+import qualified Distribution.Simple.PackageIndex as PackageIndex+import Distribution.Version   (Version)+import Distribution.Verbosity (Verbosity)+import Distribution.Text+         ( Text(disp), display ) -import Distribution.Client.Utils (mergeBy, MergeResult(..))+import Distribution.Client.Types+         ( AvailablePackage(..), Repo, AvailablePackageDb(..)+         , UnresolvedDependency(..) )+import Distribution.Client.Setup+         ( ListFlags(..), InfoFlags(..) )+import Distribution.Client.Utils+         ( mergeBy, MergeResult(..) )+import Distribution.Client.IndexUtils as IndexUtils+         ( getAvailablePackages, disambiguateDependencies )+import Distribution.Client.Fetch+         ( isFetched ) +import Data.List+         ( sortBy, groupBy, sort, nub, intersperse, maximumBy )+import Data.Maybe+         ( listToMaybe, fromJust, fromMaybe, isJust, isNothing )+import Control.Monad+         ( MonadPlus(mplus), join )+import Control.Exception+         ( assert )+import Text.PrettyPrint.HughesPJ as Disp+import System.Directory+         ( doesDirectoryExist )++ -- |Show information about packages list :: Verbosity      -> PackageDB@@ -68,7 +85,7 @@      if simpleOutput       then putStr $ unlines-             [ display(name pkg) ++ " " ++ display version+             [ display (pkgname pkg) ++ " " ++ display version              | pkg <- matches              , version <- if onlyInstalled                             then              installedVersions pkg@@ -77,7 +94,7 @@       else         if null matches             then notice verbosity "No matches found."-            else putStr $ unlines (map showPackageInfo matches)+            else putStr $ unlines (map showPackageSummaryInfo matches)   where     installedFilter       | onlyInstalled = filter (not . null . installedVersions)@@ -85,47 +102,167 @@     onlyInstalled = fromFlag (listInstalled listFlags)     simpleOutput  = fromFlag (listSimpleOutput listFlags) +info :: Verbosity+     -> PackageDB+     -> [Repo]+     -> Compiler+     -> ProgramConfiguration+     -> InfoFlags+     -> [UnresolvedDependency] --FIXME: just package names? or actually use the constraint+     -> IO ()+info verbosity packageDB repos comp conf _listFlags deps = do+  AvailablePackageDb available _ <- getAvailablePackages verbosity repos+  deps' <- IndexUtils.disambiguateDependencies available deps+  Just installed <- getInstalledPackages verbosity comp packageDB 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++  pkgsinfo' <- mapM updateFileSystemPackageDetails pkgsinfo+  putStr $ unlines (map showPackageDetailedInfo pkgsinfo')+ -- | 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 {-    name              :: PackageName,-    installedVersions :: [Version],-    availableVersions :: [Version],+    pkgname           :: PackageName,+    allInstalled      :: [InstalledPackageInfo],+    allAvailable      :: [AvailablePackage],+    latestInstalled   :: Maybe InstalledPackageInfo,+    latestAvailable   :: Maybe AvailablePackage,     homepage          :: String,-    category          :: String,+    bugReports        :: String,+    sourceRepo        :: String,     synopsis          :: String,-    license           :: License+    description       :: String,+    category          :: String,+    license           :: License,+--    copyright         :: String, --TODO: is this useful?+    author            :: String,+    maintainer        :: String,+    dependencies      :: [Dependency],+    flags             :: [Flag],+    hasLib            :: Bool,+    hasExe            :: Bool,+    executables       :: [String],+    modules           :: [ModuleName],+    haddockHtml       :: FilePath,+    haveTarball       :: Bool   } -showPackageInfo :: PackageDisplayInfo -> String-showPackageInfo pkg =+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}) $-     text " *" <+> disp (name pkg)+     char '*' <+> disp (pkgname pkginfo)      $+$-     (nest 6 $ vcat [-       maybeShow (availableVersions pkg)-         "Latest version available:"-         (disp . maximum)-     , maybeShow (installedVersions pkg)-         "Latest version installed:"-         (disp . maximum)-     , maybeShow (homepage pkg) "Homepage:" text-     , maybeShow (category pkg) "Category:" text-     , maybeShow (synopsis pkg) "Synopsis:" reflowParas-     , text "License: " <+> text (show (license pkg))+     (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  -> text "[ Not installed ]"+         Just pkg -> disp (packageVersion pkg)+     , maybeShow (homepage pkginfo) "Homepage:" text+     , text "License: " <+> text (show (license pkginfo))      ])      $+$ text ""   where     maybeShow [] _ _ = empty     maybeShow l  s f = text s <+> (f l)-    reflowParas = vcat-                . intersperse (text "")           -- re-insert blank lines-                . map (fsep . map text . concatMap words)  -- reflow paras-                . filter (/= [""])-                . groupBy (\x y -> "" `notElem` [x,y])  -- break on blank lines-                . lines +showPackageDetailedInfo :: PackageDisplayInfo -> String+showPackageDetailedInfo pkginfo =+  renderStyle (style {lineLength = 80, ribbonsPerLine = 1}) $+   char '*' <+> disp (pkgname 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 "Homepage"      homepage     orNotSpecified text+   , entry "Bug reports"   bugReports   orNotSpecified text+   , entry "Description"   description  alwaysShow     reflowParagraphs+   , entry "Category"      category     hideIfNull     text+   , entry "License"       license      alwaysShow     disp+   , entry "Author"        author       hideIfNull     reflowLines+   , entry "Maintainer"    maintainer   hideIfNull     reflowLines+   , entry "Source repo"   sourceRepo   orNotSpecified text+   , entry "Executables"   executables  hideIfNull     (commaSep text)+   , entry "Flags"         flags        hideIfNull     (commaSep dispFlag)+   , entry "Dependencies"  dependencies hideIfNull     (commaSep disp)+   , entry "Documentation" haddockHtml  showIfInstalled text+   , entry "Cached"        haveTarball  alwaysShow     dispYesNo+   , if not (hasLib pkginfo) then empty else+     text "Modules:" $+$ nest 4 (vcat (map disp . sort . modules $ pkginfo))+   ])+   $+$ text ""+  where+    entry fname field cond format = case cond (field pkginfo) of+      Nothing           -> label <+> format (field pkginfo)+      Just Nothing      -> empty+      Just (Just other) -> label <+> text other+      where+        label   = text fname <> char ':' <> padding+        padding = text (replicate (13 - length fname ) ' ')++    normal      = Nothing+    hide        = Just Nothing+    replace msg = Just (Just msg)++    alwaysShow = const normal+    hideIfNull v = if null v then hide else normal+    showIfInstalled v+      | not isInstalled = hide+      | null v          = replace "[ Not installed ]"+      | otherwise       = normal+    altText nul msg v = if nul v then replace msg else normal+    orNotSpecified = altText null "[ Not specified ]"++    commaSep f = Disp.fsep . Disp.punctuate (Disp.char ',') . map f+    dispFlag f = case flagName f of FlagName n -> text n+    dispYesNo True  = text "Yes"+    dispYesNo False = text "No"++    isInstalled = not (null (installedVersions pkginfo))+    hasExes = length (executables pkginfo) >= 2+    --TODO: exclude non-buildable exes+    pkgkind | hasLib pkginfo && hasExes        = text "programs and library"+            | hasLib pkginfo && hasExe pkginfo = text "program and library"+            | hasLib pkginfo                   = text "library"+            | hasExes                          = text "programs"+            | hasExe pkginfo                   = text "program"+            | otherwise                        = empty++reflowParagraphs :: String -> Doc+reflowParagraphs =+    vcat+  . intersperse (text "")                    -- re-insert blank lines+  . map (fsep . map text . concatMap words)  -- reflow paragraphs+  . filter (/= [""])+  . groupBy (\x y -> "" `notElem` [x,y])     -- break on blank lines+  . lines++reflowLines :: String -> Doc+reflowLines = vcat . map text . lines+ -- | We get the 'PackageDisplayInfo' by combining the info for the installed -- and available versions of a package. --@@ -136,31 +273,78 @@ mergePackageInfo :: [InstalledPackageInfo]                  -> [AvailablePackage]                  -> PackageDisplayInfo-mergePackageInfo installed available =-  assert (length installed + length available > 0) $+mergePackageInfo installedPkgs availablePkgs =+  assert (length installedPkgs + length availablePkgs > 0) $   PackageDisplayInfo {-    name              = combine (pkgName . packageId) latestAvailable-                                (pkgName . packageId) latestInstalled,-    installedVersions = map (pkgVersion . packageId) installed,-    availableVersions = map (pkgVersion . packageId) available,-    homepage          = combine Available.homepage latestAvailableDesc-                                Installed.homepage latestInstalled,-    category          = combine Available.category latestAvailableDesc-                                Installed.category latestInstalled,-    synopsis          = combine Available.synopsis latestAvailableDesc-                                Installed.description latestInstalled,-    license           = combine Available.license  latestAvailableDesc-                                Installed.license latestInstalled+    pkgname      = combine packageName available+                           packageName installed,+    allInstalled = installedPkgs,+    allAvailable = availablePkgs,+    latestInstalled = latest installedPkgs,+    latestAvailable = latest availablePkgs,+    license      = combine Available.license    available+                           Installed.license    installed,+    maintainer   = combine Available.maintainer available+                           Installed.maintainer installed,+    author       = combine Available.author     available+                           Installed.author     installed,+    homepage     = combine Available.homepage   available+                           Installed.homepage   installed,+    bugReports   = maybe "" Available.bugReports available,+    sourceRepo   = fromMaybe "" . join+                 . fmap (uncons Nothing Available.repoLocation+                       . sortBy (comparing Available.repoKind)+                       . Available.sourceRepos)+                 $ available,+    synopsis     = combine Available.synopsis    available+                           Installed.description installed,+    description  = combine Available.description available+                           Installed.description installed,+    category     = combine Available.category    available+                           Installed.category    installed,+    flags        = maybe [] Available.genPackageFlags availableGeneric,+    hasLib       = isJust installed+                || fromMaybe False+                   (fmap (isJust . Available.condLibrary) availableGeneric),+    hasExe       = fromMaybe False+                   (fmap (not . null . Available.condExecutables) availableGeneric),+    executables  = map fst (maybe [] Available.condExecutables availableGeneric),+    modules      = combine Installed.exposedModules installed+                           (maybe [] Available.exposedModules+                                   . Available.library) available,+    dependencies = combine Available.buildDepends available+                           (map thisPackageVersion+                             . Installed.depends) installed,+    haddockHtml  = fromMaybe "" . join+                 . fmap (listToMaybe . Installed.haddockHTMLs)+                 $ installed,+    haveTarball  = False   }   where-    combine f x g y = fromJust (fmap f x `mplus` fmap g y)-    latestInstalled = latestOf installed-    latestAvailable = latestOf available-    latestAvailableDesc = fmap (Available.packageDescription . packageDescription)-                          latestAvailable-    latestOf :: Package pkg => [pkg] -> Maybe pkg-    latestOf = listToMaybe . sortBy (comparing (pkgVersion . packageId))+    combine f x g y  = fromJust (fmap f x `mplus` fmap g y)+    installed        = latest installedPkgs+    availableGeneric = fmap packageDescription (latest availablePkgs)+    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)+  docsExist <- doesDirectoryExist (haddockHtml pkginfo)+  return pkginfo {+    haveTarball = fetched,+    haddockHtml = if docsExist then haddockHtml pkginfo else ""+  }+ -- | 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.@@ -170,8 +354,8 @@ mergePackages installed available =     map collect   $ mergeBy (\i a -> fst i `compare` fst a)-            (groupOn (pkgName . packageId) installed)-            (groupOn (pkgName . packageId) available)+            (groupOn packageName installed)+            (groupOn packageName available)   where     collect (OnlyInLeft  (_,is)       ) = (is, [])     collect (    InBoth  (_,is) (_,as)) = (is, as)

Distribution/Client/Setup.hs view

@@ -12,16 +12,19 @@ ----------------------------------------------------------------------------- module Distribution.Client.Setup     ( globalCommand, GlobalFlags(..), globalRepos-    , configureCommand, Cabal.ConfigFlags(..), filterConfigureFlags, configPackageDB'+    , configureCommand, ConfigFlags(..), filterConfigureFlags, configPackageDB'+    , configureExCommand, ConfigExFlags(..), defaultConfigExFlags+                        , configureExOptions     , installCommand, InstallFlags(..), installOptions, defaultInstallFlags     , listCommand, ListFlags(..)     , updateCommand     , upgradeCommand-    , infoCommand+    , infoCommand, InfoFlags(..)     , fetchCommand     , checkCommand     , uploadCommand, UploadFlags(..)     , reportCommand+    , unpackCommand, UnpackFlags(..)      , parsePackageArgs     --TODO: stop exporting these:@@ -31,18 +34,24 @@  import Distribution.Client.Types          ( Username(..), Password(..), Repo(..), RemoteRepo(..), LocalRepo(..) )+import Distribution.Client.BuildReports.Types+         ( ReportLevel(..) )  import Distribution.Simple.Program          ( defaultProgramConfiguration ) import Distribution.Simple.Command hiding (boolOpt) import qualified Distribution.Simple.Command as Command import qualified Distribution.Simple.Setup as Cabal-         ( ConfigFlags(..), configureCommand )+         ( configureCommand ) import Distribution.Simple.Setup+         ( ConfigFlags(..) )+import Distribution.Simple.Setup          ( Flag(..), toFlag, fromFlag, flagToList, flagToMaybe, fromFlagOrDefault          , optionVerbosity, trueArg ) import Distribution.Simple.Compiler          ( PackageDB(..) )+import Distribution.Simple.InstallDirs+         ( PathTemplate, toPathTemplate, fromPathTemplate ) import Distribution.Version          ( Version(Version), VersionRange(..) ) import Distribution.Package@@ -97,16 +106,17 @@ globalCommand = CommandUI {     commandName         = "",     commandSynopsis     = "",+    commandUsage        = \_ ->+         "This program is the command line interface "+           ++ "to the Haskell Cabal infrastructure.\n"+      ++ "See http://www.haskell.org/cabal/ for more information.\n",     commandDescription  = Just $ \pname ->-         "Typical step for installing Cabal packages:\n"-      ++ "  " ++ pname ++ " install [PACKAGES]\n"-      ++ "\nOccasionally you need to update the list of available packages:\n"-      ++ "  " ++ pname ++ " update\n"-      ++ "\nFor more information about a command, try '"-          ++ pname ++ " COMMAND --help'."-      ++ "\nThis program is the command line interface to the Haskell Cabal Infrastructure."-      ++ "\nSee http://www.haskell.org/cabal/ for more information.\n",-    commandUsage        = \_ -> [],+         "For more information about a command use:\n"+      ++ "  " ++ pname ++ " COMMAND --help\n\n"+      ++ "To install Cabal packages from hackage use:\n"+      ++ "  " ++ pname ++ " install foo [--dry-run]\n\n"+      ++ "Occasionally you need to update the list of available packages:\n"+      ++ "  " ++ pname ++ " update\n",     commandDefaultFlags = defaultGlobalFlags,     commandOptions      = \showOrParseArgs ->       (case showOrParseArgs of ShowArgs -> take 2; ParseArgs -> id)@@ -177,27 +187,85 @@ -- * Config flags -- ------------------------------------------------------------ -configureCommand :: CommandUI Cabal.ConfigFlags+configureCommand :: CommandUI ConfigFlags configureCommand = (Cabal.configureCommand defaultProgramConfiguration) {     commandDefaultFlags = mempty   } -configPackageDB' :: Cabal.ConfigFlags -> PackageDB+configureOptions ::  ShowOrParseArgs -> [OptionField ConfigFlags]+configureOptions = commandOptions configureCommand++configPackageDB' :: ConfigFlags -> PackageDB configPackageDB' config =-  fromFlagOrDefault defaultDB (Cabal.configPackageDB config)+  fromFlagOrDefault defaultDB (configPackageDB config)   where-    defaultDB = case Cabal.configUserInstall config of+    defaultDB = case configUserInstall config of       NoFlag     -> UserPackageDB       Flag True  -> UserPackageDB       Flag False -> GlobalPackageDB -filterConfigureFlags :: Cabal.ConfigFlags -> Version -> Cabal.ConfigFlags+filterConfigureFlags :: ConfigFlags -> Version -> ConfigFlags filterConfigureFlags flags cabalLibVersion   | cabalLibVersion >= Version [1,3,10] [] = flags     -- older Cabal does not grok the constraints flag:-  | otherwise = flags { Cabal.configConstraints = [] }+  | otherwise = flags { configConstraints = [] } + -- ------------------------------------------------------------+-- * Config extra flags+-- ------------------------------------------------------------++-- | cabal configure takes some extra flags beyond runghc Setup configure+--+data ConfigExFlags = ConfigExFlags {+    configCabalVersion :: Flag Version,+    configPreferences  :: [Dependency]+  }++defaultConfigExFlags :: ConfigExFlags+defaultConfigExFlags = mempty++configureExCommand :: CommandUI (ConfigFlags, ConfigExFlags)+configureExCommand = configureCommand {+    commandDefaultFlags = (mempty, defaultConfigExFlags),+    commandOptions      = \showOrParseArgs ->+         liftOptions fst setFst (configureOptions   showOrParseArgs)+      ++ liftOptions snd setSnd (configureExOptions showOrParseArgs)+  }+  where+    setFst a (_,b) = (a,b)+    setSnd b (a,_) = (a,b)++configureExOptions ::  ShowOrParseArgs -> [OptionField ConfigExFlags]+configureExOptions _showOrParseArgs =+  [ option [] ["cabal-lib-version"]+      ("Select which version of the Cabal lib to use to build packages "+      ++ "(useful for testing).")+      configCabalVersion (\v flags -> flags { configCabalVersion = v })+      (reqArg "VERSION" (readP_to_E ("Cannot parse cabal lib version: "++)+                                    (fmap toFlag parse))+                        (map display . flagToList))++  , option [] ["preference"]+      "Specify preferences (soft constraints) on the version of a package"+      configPreferences (\v flags -> flags { configPreferences = v })+      (reqArg "DEPENDENCY"+        (readP_to_E (const "dependency expected") ((\x -> [x]) `fmap` parse))+                                        (map (\x -> display x)))+  ]++instance Monoid ConfigExFlags where+  mempty = ConfigExFlags {+    configCabalVersion = mempty,+    configPreferences  = mempty+  }+  mappend a b = ConfigExFlags {+    configCabalVersion = combine configCabalVersion,+    configPreferences  = combine configPreferences+  }+    where combine field = field a `mappend` field b++-- ------------------------------------------------------------ -- * Other commands -- ------------------------------------------------------------ @@ -221,13 +289,13 @@     commandOptions      = \_ -> [optionVerbosity id const]   } -upgradeCommand  :: CommandUI (Cabal.ConfigFlags, InstallFlags)+upgradeCommand  :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags) upgradeCommand = configureCommand {     commandName         = "upgrade",     commandSynopsis     = "Upgrades installed packages to the latest available version",     commandDescription  = Nothing,     commandUsage        = usagePackages "upgrade",-    commandDefaultFlags = (mempty, defaultInstallFlags),+    commandDefaultFlags = (mempty, mempty, mempty),     commandOptions      = commandOptions installCommand   } @@ -242,16 +310,6 @@     options _  = [] -} -infoCommand  :: CommandUI (Flag Verbosity)-infoCommand = CommandUI {-    commandName         = "info",-    commandSynopsis     = "Emit some info about dependency resolution",-    commandDescription  = Nothing,-    commandUsage        = usagePackages "info",-    commandDefaultFlags = toFlag normal,-    commandOptions      = \_ -> [optionVerbosity id const]-  }- checkCommand  :: CommandUI (Flag Verbosity) checkCommand = CommandUI {     commandName         = "check",@@ -259,7 +317,7 @@     commandDescription  = Nothing,     commandUsage        = \pname -> "Usage: " ++ pname ++ " check\n",     commandDefaultFlags = toFlag normal,-    commandOptions      = mempty+    commandOptions      = \_ -> []   }  reportCommand :: CommandUI (Flag Verbosity)@@ -273,6 +331,46 @@   }  -- ------------------------------------------------------------+-- * Unpack flags+-- ------------------------------------------------------------++data UnpackFlags = UnpackFlags {+      unpackDestDir :: Flag FilePath,+      unpackVerbosity :: Flag Verbosity+    }++defaultUnpackFlags :: UnpackFlags+defaultUnpackFlags = UnpackFlags {+    unpackDestDir = mempty,+    unpackVerbosity = toFlag normal+   }++unpackCommand :: CommandUI UnpackFlags+unpackCommand = CommandUI {+    commandName         = "unpack",+    commandSynopsis     = "Unpacks packages for user inspection.",+    commandDescription  = Nothing,+    commandUsage        = usagePackages "unpack",+    commandDefaultFlags = mempty,+    commandOptions      = \_ -> [+        optionVerbosity unpackVerbosity (\v flags -> flags { unpackVerbosity = v })++       ,option "d" ["destdir"]+         "where to unpack the packages, defaults to the current directory."+         unpackDestDir (\v flags -> flags { unpackDestDir = v })+         (reqArgFlag "PATH")+       ]+  }++instance Monoid UnpackFlags where+  mempty = defaultUnpackFlags+  mappend a b = UnpackFlags {+     unpackDestDir = combine unpackDestDir+    ,unpackVerbosity = combine unpackVerbosity+  }+    where combine field = field a `mappend` field b++-- ------------------------------------------------------------ -- * List flags -- ------------------------------------------------------------ @@ -292,7 +390,7 @@ listCommand  :: CommandUI ListFlags listCommand = CommandUI {     commandName         = "list",-    commandSynopsis     = "List available packages on the server (cached).",+    commandSynopsis     = "List packages matching a search string.",     commandDescription  = Nothing,     commandUsage        = usagePackages "list",     commandDefaultFlags = defaultListFlags,@@ -322,6 +420,38 @@     where combine field = field a `mappend` field b  -- ------------------------------------------------------------+-- * Info flags+-- ------------------------------------------------------------++data InfoFlags = InfoFlags {+    infoVerbosity :: Flag Verbosity+  }++defaultInfoFlags :: InfoFlags+defaultInfoFlags = InfoFlags {+    infoVerbosity = toFlag normal+  }++infoCommand  :: CommandUI InfoFlags+infoCommand = CommandUI {+    commandName         = "info",+    commandSynopsis     = "Display detailed information about a particular package.",+    commandDescription  = Nothing,+    commandUsage        = usagePackages "info",+    commandDefaultFlags = defaultInfoFlags,+    commandOptions      = \_ -> [+        optionVerbosity infoVerbosity (\v flags -> flags { infoVerbosity = v })+        ]+  }++instance Monoid InfoFlags where+  mempty = defaultInfoFlags+  mappend a b = InfoFlags {+    infoVerbosity = combine infoVerbosity+  }+    where combine field = field a `mappend` field b++-- ------------------------------------------------------------ -- * Install flags -- ------------------------------------------------------------ @@ -333,9 +463,9 @@     installReinstall    :: Flag Bool,     installOnly         :: Flag Bool,     installRootCmd      :: Flag String,-    installCabalVersion :: Flag Version,-    installLogFile      :: Flag FilePath,-    installBuildReports :: Flag Bool,+    installSummaryFile  :: [PathTemplate],+    installLogFile      :: Flag PathTemplate,+    installBuildReports :: Flag ReportLevel,     installSymlinkBinDir:: Flag FilePath   } @@ -346,22 +476,41 @@     installReinstall    = Flag False,     installOnly         = Flag False,     installRootCmd      = mempty,-    installCabalVersion = mempty,+    installSummaryFile  = mempty,     installLogFile      = mempty,-    installBuildReports = Flag False,+    installBuildReports = Flag NoReports,     installSymlinkBinDir= mempty   } -installCommand :: CommandUI (Cabal.ConfigFlags, InstallFlags)-installCommand = configureCommand {+installCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags)+installCommand = CommandUI {   commandName         = "install",   commandSynopsis     = "Installs a list of packages.",   commandUsage        = usagePackages "install",-  commandDefaultFlags = (mempty, mempty),+  commandDescription  = Just $ \pname ->+    let original = case commandDescription configureCommand of+          Just desc -> desc pname ++ "\n"+          Nothing   -> ""+     in original+     ++ "Examples:\n"+     ++ "  " ++ pname ++ " install                 "+     ++ "    Package in the current directory\n"+     ++ "  " ++ pname ++ " install foo             "+     ++ "    Package from the hackage server\n"+     ++ "  " ++ pname ++ " install foo-1.0         "+     ++ "    Specific version of a package\n"+     ++ "  " ++ pname ++ " install 'foo < 2'       "+     ++ "    Constrained package version\n",+  commandDefaultFlags = (mempty, mempty, mempty),   commandOptions      = \showOrParseArgs ->-    liftOptionsFst (commandOptions configureCommand showOrParseArgs) ++-    liftOptionsSnd (installOptions showOrParseArgs)+       liftOptions get1 set1 (configureOptions   showOrParseArgs)+    ++ liftOptions get2 set2 (configureExOptions showOrParseArgs)+    ++ liftOptions get3 set3 (installOptions     showOrParseArgs)   }+  where+    get1 (a,_,_) = a; set1 a (_,b,c) = (a,b,c)+    get2 (_,b,_) = b; set2 b (a,_,c) = (a,b,c)+    get3 (_,_,c) = c; set3 c (a,b,_) = (a,b,c)  installOptions ::  ShowOrParseArgs -> [OptionField InstallFlags] installOptions showOrParseArgs =@@ -390,23 +539,24 @@            installSymlinkBinDir (\v flags -> flags { installSymlinkBinDir = v })            (reqArgFlag "DIR") -      , option [] ["cabal-lib-version"]-          ("Select which version of the Cabal lib to use to build packages "-          ++ "(useful for testing).")-          installCabalVersion (\v flags -> flags { installCabalVersion = v })-          (reqArg "VERSION" (readP_to_E ("Cannot parse cabal lib version: "++)-                                        (fmap toFlag parse))-                            (map display . flagToList))+      , option [] ["build-summary"]+          "Save build summaries to file (name template can use $pkgid, $compiler, $os, $arch)"+          installSummaryFile (\v flags -> flags { installSummaryFile = v })+          (reqArg' "TEMPLATE" (\x -> [toPathTemplate x]) (map fromPathTemplate)) -      , option [] ["log-builds"]+      , option [] ["build-log"]           "Log all builds to file (name template can use $pkgid, $compiler, $os, $arch)"           installLogFile (\v flags -> flags { installLogFile = v })-          (reqArg' "FILE" toFlag flagToList)+          (reqArg' "TEMPLATE" (toFlag.toPathTemplate)+                              (flagToList . fmap fromPathTemplate)) -      , option [] ["build-reports"]-          "Generate detailed build reports. (overrides --log-builds)"+      , option [] ["remote-build-reporting"]+          "Generate build reports to send to a remote server (none, anonymous or detailed)."           installBuildReports (\v flags -> flags { installBuildReports = v })-          trueArg+          (reqArg "LEVEL" (readP_to_E (const $ "report level must be 'none', "+                                            ++ "'anonymous' or 'detailed'")+                                      (toFlag `fmap` parse))+                          (flagToList . fmap display))        ] ++ case showOrParseArgs of      -- TODO: remove when "cabal install" avoids           ParseArgs ->@@ -424,7 +574,7 @@     installReinstall    = mempty,     installOnly         = mempty,     installRootCmd      = mempty,-    installCabalVersion = mempty,+    installSummaryFile  = mempty,     installLogFile      = mempty,     installBuildReports = mempty,     installSymlinkBinDir= mempty@@ -435,7 +585,7 @@     installReinstall    = combine installReinstall,     installOnly         = combine installOnly,     installRootCmd      = combine installRootCmd,-    installCabalVersion = combine installCabalVersion,+    installSummaryFile  = combine installSummaryFile,     installLogFile      = combine installLogFile,     installBuildReports = combine installBuildReports,     installSymlinkBinDir= combine installSymlinkBinDir@@ -519,11 +669,9 @@               (b -> Flag String) -> (Flag String -> b -> b) -> OptDescr b reqArgFlag ad = reqArg ad (succeedReadE Flag) flagToList -liftOptionsFst :: [OptionField a] -> [OptionField (a,b)]-liftOptionsFst = map (liftOption fst (\a (_,b) -> (a,b)))--liftOptionsSnd :: [OptionField b] -> [OptionField (a,b)]-liftOptionsSnd = map (liftOption snd (\b (a,_) -> (a,b)))+liftOptions :: (b -> a) -> (a -> b -> b)+            -> [OptionField a] -> [OptionField b]+liftOptions get set = map (liftOption get set)  usagePackages :: String -> String -> String usagePackages name pname =

Distribution/Client/SetupWrapper.hs view

@@ -73,6 +73,7 @@ data SetupScriptOptions = SetupScriptOptions {     useCabalVersion  :: VersionRange,     useCompiler      :: Maybe Compiler,+    usePackageDB     :: PackageDB,     usePackageIndex  :: Maybe (PackageIndex InstalledPackageInfo),     useProgramConfig :: ProgramConfiguration,     useDistPref      :: FilePath,@@ -84,6 +85,7 @@ defaultSetupScriptOptions = SetupScriptOptions {     useCabalVersion  = AnyVersion,     useCompiler      = Nothing,+    usePackageDB     = UserPackageDB,     usePackageIndex  = Nothing,     useProgramConfig = emptyProgramConfiguration,     useDistPref      = defaultDistPref,@@ -202,8 +204,8 @@     index <- case usePackageIndex options' of       Just index -> return index       Nothing    -> fromMaybe mempty-             `fmap` getInstalledPackages verbosity comp UserPackageDB conf-                    -- user packages are *allowed* here, no portability problem+             `fmap` getInstalledPackages verbosity+                      comp (usePackageDB options') conf      let cabalDep = Dependency (PackageName "Cabal") (useCabalVersion options)     case PackageIndex.lookupDependency index cabalDep of@@ -279,7 +281,12 @@           ghcVerbosityOptions verbosity        ++ ["--make", setupHsFile, "-o", setupProgFile           ,"-odir", setupDir, "-hidir", setupDir-	  ,"-i", "-i" ++ workingDir ]+          ,"-i", "-i" ++ workingDir ]+       ++ (case usePackageDB options' of+             GlobalPackageDB      -> ["-no-user-package-conf"]+             UserPackageDB        -> []+             SpecificPackageDB db -> ["-no-user-package-conf"+                                     ,"-package-conf", db])        ++ if packageName pkg == PackageName "Cabal"             then []             else ["-package", display cabalPkgid]

Distribution/Client/SrcDist.hs view

@@ -16,8 +16,10 @@ import Distribution.PackageDescription.Parse          ( readPackageDescription ) import Distribution.Simple.Utils-         ( withTempDirectory , defaultPackageDesc-         , die, warn, notice, setupMessage )+         ( defaultPackageDesc, warn, notice, setupMessage+         , createDirectoryIfMissingVerbose )+import Distribution.Client.Utils+         ( withTempDirectory ) import Distribution.Simple.Setup (SDistFlags(..), fromFlag) import Distribution.Verbosity (Verbosity) import Distribution.Simple.PreProcess (knownSuffixHandlers)@@ -29,7 +31,6 @@  import System.Time (getClockTime, toCalendarTime) import System.FilePath ((</>), (<.>))-import System.Directory (doesDirectoryExist) import Control.Monad (when) import Data.Maybe (isNothing) @@ -40,20 +41,16 @@      =<< readPackageDescription verbosity      =<< defaultPackageDesc verbosity   mb_lbi <- maybeGetPersistBuildConfig distPref-  let tmpDir = srcPref distPref+  let tmpTargetDir = srcPref distPref    -- do some QA   printPackageProblems verbosity pkg -  exists <- doesDirectoryExist tmpDir-  when exists $-    die $ "Source distribution already in place. please move or remove: "-       ++ tmpDir-   when (isNothing mb_lbi) $     warn verbosity "Cannot run preprocessors. Run 'configure' command first." -  withTempDirectory verbosity tmpDir $ do+  createDirectoryIfMissingVerbose verbosity True tmpTargetDir+  withTempDirectory tmpTargetDir "sdist." $ \tmpDir -> do      date <- toCalendarTime =<< getClockTime     let pkg' | snapshot  = snapshotPackage date pkg

Distribution/Client/Tar.hs view

@@ -618,29 +618,37 @@ --  unpack :: FilePath -> Entries -> IO ()-unpack dir entries = extractLinks =<< extractFiles [] entries+unpack baseDir entries = extractLinks =<< extractFiles [] entries   where     extractFiles _     (Fail err)            = Prelude.fail err     extractFiles links Done                  = return links     extractFiles links (Next entry entries') = case fileType entry of-      NormalFile   -> BS.writeFile (dir </> fileName entry) (fileContent entry)-                   >> extractFiles links entries'-      HardLink     -> saveLink-      SymbolicLink -> saveLink-      Directory    -> createDirectoryIfMissing False (dir </> fileName entry)-                   >> extractFiles links entries'+      NormalFile   -> extractFile entry >> extractFiles links entries'+      HardLink     -> extractFiles (saveLink entry links) entries'+      SymbolicLink -> extractFiles (saveLink entry links) entries'+      Directory    -> extractDir entry >> extractFiles links entries'       _            -> extractFiles links entries' -- FIXME: warning?++    extractFile entry = do+      createDirectoryIfMissing False fileDir+      BS.writeFile fullPath (fileContent entry)       where-        saveLink    = seq (length name)-                    $ seq (length name)-                    $ extractFiles (link:links) entries'-          where-            name    = fileName entry-            target  = linkTarget entry-            link    = (name, target)+        fileDir  = baseDir </> FilePath.Native.takeDirectory (fileName entry)+        fullPath = baseDir </> fileName entry +    extractDir entry =+      createDirectoryIfMissing False (baseDir </> fileName entry)++    saveLink entry links = seq (length name)+                         $ seq (length name)+                         $ link:links+      where+        name    = fileName entry+        target  = linkTarget entry+        link    = (name, target)+     extractLinks = mapM_ $ \(name, target) ->-      let path      = dir </> name+      let path      = baseDir </> name        in copyFile (FilePath.Native.takeDirectory path </> target) path  --

+ Distribution/Client/Unpack.hs view

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

Distribution/Client/Update.hs view

@@ -15,29 +15,59 @@     ) where  import Distribution.Client.Types-         ( Repo(..), RemoteRepo(..), LocalRepo(..) )+         ( Repo(..), RemoteRepo(..), LocalRepo(..), AvailablePackageDb(..) ) import Distribution.Client.Fetch          ( downloadIndex ) import qualified Distribution.Client.Utils as BS          ( writeFileAtomic )+import qualified Distribution.Simple.PackageIndex as PackageIndex+import Distribution.Client.IndexUtils+         ( getAvailablePackages )+import qualified Paths_cabal_install+         ( version ) -import Distribution.Simple.Utils (notice)-import Distribution.Verbosity (Verbosity)+import Distribution.Package+         ( PackageName(..), packageId, packageVersion )+import Distribution.Simple.Utils+         ( warn, notice, comparing )+import Distribution.Verbosity+         ( Verbosity )  import qualified Data.ByteString.Lazy as BS import qualified Codec.Compression.GZip as GZip (decompress) import System.FilePath (dropExtension)+import Data.List (maximumBy)  -- | 'update' downloads the package list from all known servers update :: Verbosity -> [Repo] -> IO ()-update verbosity = mapM_ (updateRepo verbosity)+update verbosity [] = do+  warn verbosity $ "No remote package servers have been specified. Usually "+                ++ "you would have one specified in the config file."+update verbosity repos = do+  mapM_ (updateRepo verbosity) repos+  checkForSelfUpgrade verbosity repos  updateRepo :: Verbosity -> Repo -> IO () updateRepo verbosity repo = case repoKind repo of   Right LocalRepo -> return ()   Left remoteRepo -> do-    notice verbosity $ "Downloading package list from server '"-                    ++ show (remoteRepoURI remoteRepo) ++ "'"+    notice verbosity $ "Downloading the latest package list from "+                    ++ remoteRepoName remoteRepo     indexPath <- downloadIndex verbosity remoteRepo (repoLocalDir repo)     BS.writeFileAtomic (dropExtension indexPath) . GZip.decompress                                                =<< BS.readFile indexPath++checkForSelfUpgrade :: Verbosity -> [Repo] -> IO ()+checkForSelfUpgrade verbosity repos = do+  AvailablePackageDb available _ <- getAvailablePackages verbosity repos++  let self = PackageName "cabal-install"+      pkgs = PackageIndex.lookupPackageName available self+      latestVersion  = packageVersion (maximumBy (comparing packageId) pkgs)+      currentVersion = Paths_cabal_install.version++  if not (null pkgs) && latestVersion > currentVersion+    then notice verbosity $+              "Note: there is a new version of cabal-install available.\n"+           ++ "To upgrade, run: cabal install cabal-install"+    else return ()

Distribution/Client/Upload.hs view

@@ -21,6 +21,7 @@ import Network.HTTP          ( Header(..), HeaderName(..), findHeader          , Request(..), RequestMethod(..), Response(..) )+import Network.TCP (HandleStream) import Network.URI (URI(uriPath), parseURI)  import Data.Char        (intToDigit)@@ -29,7 +30,7 @@                         ,openBinaryFile, IOMode(ReadMode), hGetContents) import Control.Exception (bracket) import System.Random    (randomRIO)-import System.FilePath  ((</>), takeExtension)+import System.FilePath  ((</>), takeExtension, takeFileName) import qualified System.FilePath.Posix as FilePath.Posix (combine) import System.Directory import Control.Monad (forM_)@@ -73,9 +74,11 @@       putStr "Hackage password: "       hFlush stdout       -- save/restore the terminal echoing status-      bracket (hGetEcho stdin) (hSetEcho stdin) $ \_ -> do+      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] -> IO () report verbosity repos@@ -102,7 +105,8 @@             notice verbosity $ "Checking " ++ path ++ "... "             handlePackage verbosity checkURI (return ()) path -handlePackage :: Verbosity -> URI -> BrowserAction () -> FilePath -> IO ()+handlePackage :: Verbosity -> URI -> BrowserAction (HandleStream String) ()+              -> FilePath -> IO () handlePackage verbosity uri auth path =   do req <- mkRequest uri path      p   <- proxy verbosity@@ -124,7 +128,7 @@                        Just "text/plain" -> notice verbosity $ rspBody resp                        _                 -> debug verbosity $ rspBody resp -mkRequest :: URI -> FilePath -> IO Request+mkRequest :: URI -> FilePath -> IO (Request String) mkRequest uri path =      do pkg <- readBinaryFile path        boundary <- genBoundary@@ -146,11 +150,12 @@                  return $ showHex i ""  mkFormData :: FilePath -> String -> [BodyPart]-mkFormData path pkg = -    -- yes, web browsers are that stupid (re quoting)-    [BodyPart [Header hdrContentDisposition ("form-data; name=package; filename=\""++path++"\""),-               Header HdrContentType "application/x-gzip"] -     pkg]+mkFormData path pkg =+  -- yes, web browsers are that stupid (re quoting)+  [BodyPart [Header hdrContentDisposition $+             "form-data; name=package; filename=\""++takeFileName path++"\"",+             Header HdrContentType "application/x-gzip"]+   pkg]  hdrContentDisposition :: HeaderName hdrContentDisposition = HdrCustom "Content-disposition"

Distribution/Client/Utils.hs view

@@ -13,9 +13,11 @@          ( isDoesNotExistError ) import System.Directory          ( removeFile, renameFile, doesFileExist, getModificationTime-         , getCurrentDirectory, setCurrentDirectory )+         , getCurrentDirectory, setCurrentDirectory, removeDirectoryRecursive )+import Distribution.Compat.TempFile+         ( createTempDirectory ) import qualified Control.Exception as Exception-         ( handle, throwIO, evaluate, finally )+         ( handle, throwIO, evaluate, finally, bracket )  -- | Generic merging utility. For sorted input lists this is a full outer join. --@@ -91,6 +93,13 @@   where     mightNotExist e | isDoesNotExistError e = writeFile path newContent                     | otherwise             = ioError e++--TODO: replace with function from Cabal utils in next version+withTempDirectory :: FilePath -> String -> (FilePath -> IO a) -> IO a+withTempDirectory targetDir template =+  Exception.bracket+    (createTempDirectory targetDir template)+    (removeDirectoryRecursive)  -- | Executes the action in the specified directory. inDir :: Maybe FilePath -> IO () -> IO ()

Distribution/Client/Win32SelfUpgrade.hs view

@@ -1,7 +1,4 @@-{-# OPTIONS -cpp -fffi #-}--- OPTIONS required for ghc-6.4.x compat, and must appear first {-# LANGUAGE CPP, ForeignFunctionInterface #-}-{-# OPTIONS_GHC -cpp -fffi #-} {-# OPTIONS_NHC98 -cpp #-} {-# OPTIONS_JHC -fcpp -fffi #-} -----------------------------------------------------------------------------

+ Distribution/Compat/TempFile.hs view

@@ -0,0 +1,28 @@+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -cpp #-}+{-# OPTIONS_NHC98 -cpp #-}+{-# OPTIONS_JHC -fcpp #-}+-- #hide+module Distribution.Compat.TempFile (+  createTempDirectory,+  ) where++import System.FilePath        ((</>))+import System.Posix.Internals (mkdir, c_getpid)+import Foreign.C              (withCString, getErrno, eEXIST, errnoToIOError)++createTempDirectory :: FilePath -> String -> IO FilePath+createTempDirectory dir template = do+  pid <- c_getpid+  findTempName pid+  where+    findTempName x = do+      let dirpath = dir </> template ++ show x+      res <- withCString dirpath $ \s -> mkdir s 0o700+      if res == 0+        then return dirpath+        else do+          errno <- getErrno+          if errno == eEXIST+            then findTempName (x+1)+            else ioError (errnoToIOError "createTempDirectory" errno Nothing (Just dir))

Main.hs view

@@ -15,13 +15,16 @@  import Distribution.Client.Setup          ( GlobalFlags(..), globalCommand, globalRepos-         , ConfigFlags(..), configureCommand+         , ConfigFlags(..)+         , ConfigExFlags(..), configureExCommand          , InstallFlags(..), installCommand, upgradeCommand          , fetchCommand, checkCommand          , updateCommand          , ListFlags(..), listCommand+         , InfoFlags(..), infoCommand          , UploadFlags(..), uploadCommand          , reportCommand+         , unpackCommand, UnpackFlags(..)          , parsePackageArgs, configPackageDB' ) import Distribution.Simple.Setup          ( BuildFlags(..), buildCommand@@ -39,15 +42,17 @@ import Distribution.Client.SetupWrapper          ( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions ) import Distribution.Client.Config-         ( SavedConfig(..), loadConfig )-import Distribution.Client.List             (list)+         ( SavedConfig(..), loadConfig, defaultConfigFile )+import Distribution.Client.List             (list, info) import Distribution.Client.Install          (install, upgrade)+import Distribution.Client.Configure        (configure) import Distribution.Client.Update           (update) import Distribution.Client.Fetch            (fetch) import Distribution.Client.Check as Check   (check) --import Distribution.Client.Clean            (clean) import Distribution.Client.Upload as Upload (upload, check, report) import Distribution.Client.SrcDist          (sdist)+import Distribution.Client.Unpack           (unpack) import qualified Distribution.Client.Win32SelfUpgrade as Win32SelfUpgrade  import Distribution.Simple.Program (defaultProgramConfiguration)@@ -78,20 +83,28 @@ mainWorker ("win32selfupgrade":args) = win32SelfUpgradeAction args mainWorker args =   case commandsRun globalCommand commands args of-    CommandHelp   help                 -> printHelp help+    CommandHelp   help                 -> printGlobalHelp help     CommandList   opts                 -> printOptionsList opts     CommandErrors errs                 -> printErrors errs     CommandReadyToGo (globalflags, commandParse)  ->       case commandParse of         _ | fromFlag (globalVersion globalflags)        -> printVersion           | fromFlag (globalNumericVersion globalflags) -> printNumericVersion-        CommandHelp     help           -> printHelp help+        CommandHelp     help           -> printCommandHelp help         CommandList     opts           -> printOptionsList opts         CommandErrors   errs           -> printErrors errs         CommandReadyToGo action        -> action globalflags    where-    printHelp help = getProgName >>= putStr . help+    printCommandHelp help = do+      pname <- getProgName+      putStr (help pname)+    printGlobalHelp help = do+      pname <- getProgName+      configFile <- defaultConfigFile+      putStr (help pname)+      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))@@ -104,9 +117,10 @@                                   ++ " of the Cabal library "      commands =-      [configureCommand       `commandAddAction` configureAction+      [configureExCommand     `commandAddAction` configureAction       ,installCommand         `commandAddAction` installAction       ,listCommand            `commandAddAction` listAction+      ,infoCommand            `commandAddAction` infoAction       ,updateCommand          `commandAddAction` updateAction       ,upgradeCommand         `commandAddAction` upgradeAction       ,fetchCommand           `commandAddAction` fetchAction@@ -114,6 +128,7 @@       ,checkCommand           `commandAddAction` checkAction       ,sdistCommand           `commandAddAction` sdistAction       ,reportCommand          `commandAddAction` reportAction+      ,unpackCommand          `commandAddAction` unpackAction       ,wrapperAction (buildCommand defaultProgramConfiguration)                      buildVerbosity    buildDistPref       ,wrapperAction copyCommand@@ -147,79 +162,102 @@     setupWrapper verbosity setupScriptOptions Nothing                  command (const flags) extraArgs -configureAction :: ConfigFlags -> [String] -> GlobalFlags -> IO ()-configureAction flags extraArgs globalFlags = do-  let verbosity = fromFlagOrDefault normal (configVerbosity flags)+configureAction :: (ConfigFlags, ConfigExFlags)+                -> [String] -> GlobalFlags -> IO ()+configureAction (configFlags, configExFlags) extraArgs globalFlags = do+  let verbosity = fromFlagOrDefault normal (configVerbosity configFlags)   config <- loadConfig verbosity (globalConfigFile globalFlags)-                                 (configUserInstall flags)-  let flags' = savedConfigureFlags config `mappend` flags-  (comp, conf) <- configCompilerAux flags'-  let setupScriptOptions = defaultSetupScriptOptions {-        useCompiler      = Just comp,-        useProgramConfig = conf,-        useDistPref      = fromFlagOrDefault-                             (useDistPref defaultSetupScriptOptions)-                             (configDistPref flags)-      }-  setupWrapper verbosity setupScriptOptions Nothing-    configureCommand (const flags') extraArgs+                                 (configUserInstall configFlags)+  let configFlags'   = savedConfigureFlags   config `mappend` configFlags+      configExFlags' = savedConfigureExFlags config `mappend` configExFlags+      globalFlags'   = savedGlobalFlags      config `mappend` globalFlags+  (comp, conf) <- configCompilerAux configFlags'+  configure verbosity+            (configPackageDB' configFlags') (globalRepos globalFlags')+            comp conf configFlags' configExFlags' extraArgs -installAction :: (ConfigFlags, InstallFlags) -> [String] -> GlobalFlags -> IO ()-installAction (cflags,iflags) _ _globalFlags-  | fromFlagOrDefault False (installOnly iflags)-  = let verbosity = fromFlagOrDefault normal (configVerbosity cflags)+installAction :: (ConfigFlags, ConfigExFlags, InstallFlags)+              -> [String] -> GlobalFlags -> IO ()+installAction (configFlags, _, installFlags) _ _globalFlags+  | fromFlagOrDefault False (installOnly installFlags)+  = let verbosity = fromFlagOrDefault normal (configVerbosity configFlags)     in setupWrapper verbosity defaultSetupScriptOptions Nothing-         installCommand mempty []+         installCommand (const mempty) [] -installAction (cflags,iflags) extraArgs globalFlags = do+installAction (configFlags, configExFlags, installFlags)+              extraArgs globalFlags = do   pkgs <- either die return (parsePackageArgs extraArgs)-  let verbosity = fromFlagOrDefault normal (configVerbosity cflags)+  let verbosity = fromFlagOrDefault normal (configVerbosity configFlags)   config <- loadConfig verbosity (globalConfigFile globalFlags)-                                 (configUserInstall cflags)-  let cflags' = savedConfigureFlags config `mappend` cflags-      iflags' = savedInstallFlags   config `mappend` iflags-  (comp, conf) <- configCompilerAux cflags'+                                 (configUserInstall configFlags)+  let configFlags'   = savedConfigureFlags   config `mappend` configFlags+      configExFlags' = savedConfigureExFlags config `mappend` configExFlags+      installFlags'  = savedInstallFlags     config `mappend` installFlags+      globalFlags'   = savedGlobalFlags      config `mappend` globalFlags+  (comp, conf) <- configCompilerAux configFlags'   install verbosity-          (configPackageDB' cflags') (globalRepos (savedGlobalFlags config))-          comp conf cflags' iflags'-          [ UnresolvedDependency pkg (configConfigurationsFlags cflags')+          (configPackageDB' configFlags') (globalRepos globalFlags')+          comp conf configFlags' configExFlags' installFlags'+          [ UnresolvedDependency pkg (configConfigurationsFlags configFlags')           | pkg <- pkgs ]  listAction :: ListFlags -> [String] -> GlobalFlags -> IO () listAction listFlags extraArgs globalFlags = do   let verbosity = fromFlag (listVerbosity listFlags)   config <- loadConfig verbosity (globalConfigFile globalFlags) mempty-  let flags = savedConfigureFlags config-  (comp, conf) <- configCompilerAux flags+  let configFlags  = savedConfigureFlags config+      globalFlags' = savedGlobalFlags    config `mappend` globalFlags+  (comp, conf) <- configCompilerAux configFlags   list verbosity-       (configPackageDB' flags)-       (globalRepos (savedGlobalFlags config))+       (configPackageDB' configFlags)+       (globalRepos globalFlags')        comp        conf        listFlags        extraArgs +infoAction :: InfoFlags -> [String] -> GlobalFlags -> IO ()+infoAction infoFlags extraArgs globalFlags = do+  pkgs <- either die return (parsePackageArgs extraArgs)+  let verbosity = fromFlag (infoVerbosity infoFlags)+  config <- loadConfig verbosity (globalConfigFile globalFlags) mempty+  let configFlags  = savedConfigureFlags config+      globalFlags' = savedGlobalFlags    config `mappend` globalFlags+  (comp, conf) <- configCompilerAux configFlags+  info verbosity+       (configPackageDB' configFlags)+       (globalRepos globalFlags')+       comp+       conf+       infoFlags+       [ UnresolvedDependency pkg []  | pkg <- pkgs ]+ updateAction :: Flag Verbosity -> [String] -> GlobalFlags -> IO () updateAction verbosityFlag extraArgs globalFlags = do   unless (null extraArgs) $ do     die $ "'update' doesn't take any extra arguments: " ++ unwords extraArgs   let verbosity = fromFlag verbosityFlag   config <- loadConfig verbosity (globalConfigFile globalFlags) mempty-  update verbosity (globalRepos (savedGlobalFlags config))+  let globalFlags' = savedGlobalFlags config `mappend` globalFlags+  update verbosity (globalRepos globalFlags') -upgradeAction :: (ConfigFlags, InstallFlags) -> [String] -> GlobalFlags -> IO ()-upgradeAction (cflags,iflags) extraArgs globalFlags = do+upgradeAction :: (ConfigFlags, ConfigExFlags, InstallFlags)+              -> [String] -> GlobalFlags -> IO ()+upgradeAction (configFlags, configExFlags, installFlags)+              extraArgs globalFlags = do   pkgs <- either die return (parsePackageArgs extraArgs)-  let verbosity = fromFlagOrDefault normal (configVerbosity cflags)+  let verbosity = fromFlagOrDefault normal (configVerbosity configFlags)   config <- loadConfig verbosity (globalConfigFile globalFlags)-                                 (configUserInstall cflags)-  let cflags' = savedConfigureFlags config `mappend` cflags-      iflags' = savedInstallFlags   config `mappend` iflags-  (comp, conf) <- configCompilerAux cflags'+                                 (configUserInstall configFlags)+  let configFlags'   = savedConfigureFlags   config `mappend` configFlags+      configExFlags' = savedConfigureExFlags config `mappend` configExFlags+      installFlags'  = savedInstallFlags     config `mappend` installFlags+      globalFlags'   = savedGlobalFlags      config `mappend` globalFlags+  (comp, conf) <- configCompilerAux configFlags'   upgrade verbosity-          (configPackageDB' cflags') (globalRepos (savedGlobalFlags config))-          comp conf cflags' iflags'-          [ UnresolvedDependency pkg (configConfigurationsFlags cflags')+          (configPackageDB' configFlags') (globalRepos globalFlags')+          comp conf configFlags' configExFlags' installFlags'+          [ UnresolvedDependency pkg (configConfigurationsFlags configFlags')           | pkg <- pkgs ]  fetchAction :: Flag Verbosity -> [String] -> GlobalFlags -> IO ()@@ -227,10 +265,11 @@   pkgs <- either die return (parsePackageArgs extraArgs)   let verbosity = fromFlag verbosityFlag   config <- loadConfig verbosity (globalConfigFile globalFlags) mempty-  let flags = savedConfigureFlags config-  (comp, conf) <- configCompilerAux flags+  let configFlags  = savedConfigureFlags config+      globalFlags' = savedGlobalFlags config `mappend` globalFlags+  (comp, conf) <- configCompilerAux configFlags   fetch verbosity-        (configPackageDB' flags) (globalRepos (savedGlobalFlags config))+        (configPackageDB' configFlags) (globalRepos globalFlags')         comp conf         [ UnresolvedDependency pkg [] --TODO: flags?         | pkg <- pkgs ]@@ -240,13 +279,13 @@   let verbosity = fromFlag (uploadVerbosity uploadFlags)   config <- loadConfig verbosity (globalConfigFile globalFlags) mempty   let uploadFlags' = savedUploadFlags config `mappend` uploadFlags-  -- FIXME: check that the .tar.gz files exist and report friendly error message if not-  let tarfiles = extraArgs-  checkTarFiles tarfiles+      globalFlags' = savedGlobalFlags config `mappend` globalFlags+      tarfiles     = extraArgs+  checkTarFiles extraArgs   if fromFlag (uploadCheck uploadFlags')     then Upload.check  verbosity tarfiles     else upload verbosity-                (globalRepos (savedGlobalFlags config))+                (globalRepos globalFlags')                 (flagToMaybe $ uploadUsername uploadFlags')                 (flagToMaybe $ uploadPassword uploadFlags')                 tarfiles@@ -288,8 +327,16 @@    let verbosity = fromFlag verbosityFlag   config <- loadConfig verbosity (globalConfigFile globalFlags) mempty+  let globalFlags' = savedGlobalFlags config `mappend` globalFlags -  Upload.report verbosity (globalRepos (savedGlobalFlags config))+  Upload.report verbosity (globalRepos globalFlags')++unpackAction :: UnpackFlags -> [String] -> GlobalFlags -> IO ()+unpackAction flags extraArgs globalFlags = do+  pkgs <- either die return (parsePackageArgs extraArgs)+  let verbosity = fromFlag (unpackVerbosity flags)+  config <- loadConfig verbosity (globalConfigFile globalFlags) mempty+  unpack flags (globalRepos (savedGlobalFlags config)) pkgs  win32SelfUpgradeAction :: [String] -> IO () win32SelfUpgradeAction (pid:path:rest) =

README view

@@ -19,12 +19,16 @@  It requires three other Haskell packages that are not always installed: - * Cabal  (1.4 or later)- * HTTP- * zlib+ * Cabal  (version 1.6  or later)+ * HTTP   (version 4000 or later)+ * zlib   (version 0.4  or later)  All of these are available from [Hackage](http://hackage.haskell.org). +Note that on some Unix systems you may need to install an additional zlib+development package using your system package manager. This is because the+Haskell zlib package uses the system zlib C library and header files.+ In future, cabal-install will be part of the Haskell Platform so will not need to be installed separately. In the mean time however you have to install it manually. Since it is just an ordinary Cabal package it can be built in the@@ -54,11 +58,10 @@ Quickstart on Windows systems ----------------------------- -For Windows users we hope to provide a pre-compiled `cabal.exe` program shortly.-In the mean time you have to build the three dependencies in [the standard way].+For Windows users we provide a pre-compiled [cabal.exe] program. Just download+it and put it somewhere on your `%PATH%`. -[the standard way]:-  http://haskell.org/haskellwiki/Cabal/How_to_install_a_Cabal_package+[cabal.exe]: http://haskell.org/cabal/release/cabal-install-latest/cabal.exe   Using cabal-install

bootstrap.sh view

@@ -6,55 +6,193 @@ # HTTP packages. It then installs cabal-install itself. # It expects to be run inside the cabal-install directory. -CABAL_VER="1.6.0.1"-HTTP_VER="3001.1.3"-ZLIB_VER="0.4.0.4"+# install settings, you can override these by setting environment vars+PREFIX=${PREFIX:-${HOME}/.cabal}+#VERBOSE+#EXTRA_CONFIGURE_OPTS +# programs, you can override these by setting environment vars+GHC=${GHC:-ghc}+GHC_PKG=${GHC_PKG:-ghc-pkg}+WGET=${WGET:-wget}+CURL=${CURL:-curl}+TAR=${TAR:-tar}+GUNZIP=${GUNZIP:-gunzip}+++# Versions of the packages to install.+# The version regex says what existing installed versions are ok.+CABAL_VER="1.6.0.2"; CABAL_VER_REGEXP="1\.6\."   # == 1.6.*+HTTP_VER="4000.0.4"; HTTP_VER_REGEXP="4000\.0\.[3456789]"+                                                 # >= 4000.0.3 && < 4000.0.10+ZLIB_VER="0.5.0.0";  ZLIB_VER_REGEXP="0\.[45]\." # >= 0.4  && < 0.6+ HACKAGE_URL="http://hackage.haskell.org/packages/archive"-CABAL_URL=${HACKAGE_URL}/Cabal/${CABAL_VER}/Cabal-${CABAL_VER}.tar.gz-HTTP_URL=${HACKAGE_URL}/HTTP/${HTTP_VER}/HTTP-${HTTP_VER}.tar.gz-ZLIB_URL=${HACKAGE_URL}/zlib/${ZLIB_VER}/zlib-${ZLIB_VER}.tar.gz -case `which wget curl` in-  *curl)-    curl -O ${CABAL_URL} -O ${HTTP_URL} -O ${ZLIB_URL}-    ;;-  *wget)-    wget -c ${CABAL_URL} ${HTTP_URL} ${ZLIB_URL}-    ;;-  *)-    echo "Failed to find a downloader. 'wget' or 'curl' is required." >&2-    exit 2-    ;;-esac+die () {+  echo+  echo "Error during cabal-install bootstrap:"+  echo $1 >&2+  exit 2+} -tar -zxf Cabal-${CABAL_VER}.tar.gz-cd Cabal-${CABAL_VER}-ghc --make Setup-./Setup configure --user && ./Setup build && ./Setup install-cd ..+# Check we're in the right directory:+grep "cabal-install" ./cabal-install.cabal > /dev/null 2>&1 \+  || die "The bootstrap.sh script must be run in the cabal-install directory" -tar -zxf HTTP-${HTTP_VER}.tar.gz-cd HTTP-${HTTP_VER}-runghc Setup configure --user && runghc Setup build && runghc Setup install-cd ..+${GHC} --numeric-version > /dev/null \+  || die "${GHC} not found (or could not be run). If ghc is installed make sure it is on your PATH or set the GHC and GHC_PKG vars."+${GHC_PKG} --version     > /dev/null \+  || die "${GHC_PKG} not found."+GHC_VER=`${GHC} --numeric-version`+GHC_PKG_VER=`${GHC_PKG} --version | cut -d' ' -f 5`+[ ${GHC_VER} = ${GHC_PKG_VER} ] \+  || die "Version mismatch between ${GHC} and ${GHC_PKG} If you set the GHC variable then set GHC_PKG too" -tar -zxf zlib-${ZLIB_VER}.tar.gz-cd zlib-${ZLIB_VER}-runghc Setup configure --user && runghc Setup build && runghc Setup install-cd ..+# Cache the list of packages:+echo "Checking installed packages for ghc-${GHC_VER}..."+${GHC_PKG} list > ghc-pkg.list \+  || die "running '${GHC_PKG} list' failed" -runghc Setup configure --user && runghc Setup build && runghc Setup install+# Will we need to install this package, or is a suitable version installed?+need_pkg () {+  PKG=$1+  VER_MATCH=$2+  ! grep " ${PKG}-${VER_MATCH}" ghc-pkg.list > /dev/null 2>&1+} -CABAL_BIN="$HOME/.cabal/bin"-echo+info_pkg () {+  PKG=$1+  VER=$2+  VER_MATCH=$3 +  if need_pkg ${PKG} ${VER_MATCH}+  then+    echo "${PKG}-${VER} will be downloaded and installed."+  else+    echo "${PKG} is already installed and the version is ok."+  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++  URL=${HACKAGE_URL}/${PKG}/${VER}/${PKG}-${VER}.tar.gz+  if which ${CURL} > /dev/null+  then+    ${CURL} -C - -O ${URL} || die "Failed to download ${PKG}."+  elif which ${WGET} > /dev/null+  then+    ${WGET} -c ${URL} || die "Failed to download ${PKG}."+  else+    die "Failed to find a downloader. 'wget' or 'curl' is required."+  fi+  [ -f "${PKG}-${VER}.tar.gz" ] \+    || die "Downloading ${URL} did not create ${PKG}-${VER}.tar.gz"+}++unpack_pkg () {+  PKG=$1+  VER=$2++  rm -rf "${PKG}-${VER}.tar" "${PKG}-${VER}"/+  ${GUNZIP} -f "${PKG}-${VER}.tar.gz" \+    || die "Failed to gunzip ${PKG}-${VER}.tar.gz"+  ${TAR} -xf "${PKG}-${VER}.tar" \+    || die "Failed to untar ${PKG}-${VER}.tar.gz"+  [ -d "${PKG}-${VER}" ] \+    || die "Unpacking ${PKG}-${VER}.tar.gz did not create ${PKG}-${VER}/"+}++install_pkg () {+  PKG=$1++  [ -x Setup ] && ./Setup clean+  [ -f Setup ] && rm Setup++  ${GHC} --make Setup -o Setup \+    || die "Compiling the Setup script failed"+  [ -x Setup ] || die "The Setup script does not exist or cannot be run"++  ./Setup configure --user "--prefix=${HOME}/.cabal" \+    --with-compiler=${GHC} --with-hc-pkg=${GHC_PKG} \+    ${EXTRA_CONFIGURE_OPTS} ${VERBOSE} \+    || die "Configuring the ${PKG} package failed"++  ./Setup build ${VERBOSE} \+    || die "Building the ${PKG} package failed"++  ./Setup install ${VERBOSE} \+    || die "Installing the ${PKG} package failed"+}++do_pkg () {+  PKG=$1+  VER=$2+  VER_MATCH=$3++  if need_pkg ${PKG} ${VER_MATCH}+  then+    echo+    echo "Downloading ${PKG}-${VER}..."+    fetch_pkg ${PKG} ${VER}+    unpack_pkg ${PKG} ${VER}+    cd "${PKG}-${VER}"+    install_pkg ${PKG} ${VER}+    cd ..+  fi+}++# Actually do something!++dep_pkg "parsec" "2\."+dep_pkg "network" "[12]\."++info_pkg "Cabal" ${CABAL_VER} ${CABAL_VER_REGEXP}+info_pkg "HTTP"  ${HTTP_VER}  ${HTTP_VER_REGEXP}+info_pkg "zlib"  ${ZLIB_VER}  ${ZLIB_VER_REGEXP}++do_pkg "Cabal" ${CABAL_VER} ${CABAL_VER_REGEXP}+do_pkg "HTTP"  ${HTTP_VER}  ${HTTP_VER_REGEXP}+do_pkg "zlib"  ${ZLIB_VER}  ${ZLIB_VER_REGEXP}++install_pkg "cabal-install"++echo+echo "==========================================="+CABAL_BIN="$PREFIX/bin" if [ -x "$CABAL_BIN/cabal" ] then-    echo "cabal successfully installed in $CABAL_BIN."-    echo "You may want to add $CABAL_BIN to your PATH."+    echo "The 'cabal' program has been installed in $CABAL_BIN/"+    echo "You should either add $CABAL_BIN to your PATH"+    echo "or copy the cabal program to a directory that is on your PATH."+    echo+    echo "By default cabal will install programs to $HOME/.cabal/bin"+    echo "If you do not want to add this directory to your PATH then"+    echo "you can change the setting in the config file $HOME/.cabal/config"+    echo "For example you could use:"+    echo "symlink-bindir: $HOME/bin" else     echo "Sorry, something went wrong." fi- echo++rm ghc-pkg.list

cabal-install.cabal view

@@ -1,10 +1,12 @@ Name:               cabal-install-Version:            0.6.0+Version:            0.6.2 Synopsis:           The command-line interface for Cabal and Hackage. Description:     The \'cabal\' command-line program simplifies the process of managing     Haskell software by automating the fetching, configuration, compilation     and installation of Haskell libraries and programs.+homepage:           http://www.haskell.org/cabal/+bug-reports:        http://hackage.haskell.org/trac/hackage/ License:            BSD3 License-File:       LICENSE Author:             Lemmih <lemmih@gmail.com>@@ -34,13 +36,17 @@     Main-Is:            Main.hs     -- We want assertion checking on even if people build with -O     -- although it is expensive, we want to catch problems early:-    Ghc-Options:        -Wall -fno-ignore-asserts+    ghc-options:        -Wall -fno-ignore-asserts+    if impl(ghc >= 6.8)+      ghc-options: -fwarn-tabs     Other-Modules:         Distribution.Client.BuildReports.Anonymous         Distribution.Client.BuildReports.Storage+        Distribution.Client.BuildReports.Types         Distribution.Client.BuildReports.Upload         Distribution.Client.Check         Distribution.Client.Config+        Distribution.Client.Configure         Distribution.Client.Dependency         Distribution.Client.Dependency.Bogus         Distribution.Client.Dependency.TopDown@@ -59,22 +65,25 @@         Distribution.Client.SrcDist         Distribution.Client.Tar         Distribution.Client.Types+        Distribution.Client.Unpack         Distribution.Client.Update         Distribution.Client.Upload         Distribution.Client.Utils         Distribution.Client.Win32SelfUpgrade+        Distribution.Compat.TempFile         Paths_cabal_install -    build-depends: Cabal >= 1.6 && < 1.7,+    build-depends: base >= 2 && < 4,+                   Cabal >= 1.6 && < 1.7,                    filepath >= 1.0,                    network >= 1 && < 3,-                   HTTP >= 3000 && < 3002,+                   HTTP >= 4000.0.2 && < 4001,                    zlib >= 0.4 && < 0.6      if flag(old-base)       build-depends: base < 3     else-      build-depends: base       >= 3   && < 4,+      build-depends: base       >= 3,                      process    >= 1   && < 1.1,                      directory  >= 1   && < 1.1,                      pretty     >= 1   && < 1.1,