packages feed

cabal-install 0.5.1 → 0.5.2

raw patch · 55 files changed

+6899/−5325 lines, 55 filesdep +unix

Dependencies added: unix

Files

+ Distribution/Client/BuildReports/Anonymous.hs view
@@ -0,0 +1,307 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Reporting+-- Copyright   :  (c) David Waern 2008+-- License     :  BSD-like+--+-- Maintainer  :  david.waern@gmail.com+-- Stability   :  experimental+-- Portability :  portable+--+-- Anonymous build report data structure, printing and parsing+--+-----------------------------------------------------------------------------+module Distribution.Client.BuildReports.Anonymous (+    BuildReport(..),+    InstallOutcome(..),+    Outcome(..),++    -- * Constructing and writing reports+    new,++    -- * parsing and pretty printing+    parse,+    parseList,+    show,+    showList,+  ) where++import Distribution.Client.Types+         ( ConfiguredPackage(..), BuildResult )+import qualified Distribution.Client.Types as BR+         ( BuildResult, BuildFailure(..), BuildSuccess(..)+         , DocsResult(..), TestsResult(..) )+import Distribution.Client.Utils+         ( mergeBy, MergeResult(..) )+import qualified Paths_cabal_install (version)++import Distribution.Package+         ( PackageIdentifier(PackageIdentifier), Package(packageId) )+import Distribution.PackageDescription+         ( FlagName(..), FlagAssignment )+--import Distribution.Version+--         ( Version )+import Distribution.System+         ( OS, Arch )+import Distribution.Compiler+         ( CompilerId )+import qualified Distribution.Text as Text+         ( Text(disp, parse) )+import Distribution.ParseUtils+         ( FieldDescr(..), ParseResult(..), Field(..)+         , simpleField, listField, ppFields, readFields+         , syntaxError, locatedErrorMsg )+import Distribution.Simple.Utils+         ( comparing )++import qualified Distribution.Compat.ReadP as Parse+         ( ReadP, pfail, munch1, skipSpaces )+import qualified Text.PrettyPrint.HughesPJ as Disp+         ( Doc, render, char, text )+import Text.PrettyPrint.HughesPJ+         ( (<+>), (<>) )++import Data.List+         ( unfoldr, sortBy )+import Data.Char as Char+         ( isAlpha, isAlphaNum )++import Prelude hiding (show)++data BuildReport+   = BuildReport {+    -- | The package this build report is about+    package         :: PackageIdentifier,++    -- | The OS and Arch the package was built on+    os              :: OS,+    arch            :: Arch,++    -- | The Haskell compiler (and hopefully version) used+    compiler        :: CompilerId,++    -- | The uploading client, ie cabal-install-x.y.z+    client          :: PackageIdentifier,++    -- | Which configurations flags we used+    flagAssignment  :: FlagAssignment,++    -- | Which dependent packages we were using exactly+    dependencies    :: [PackageIdentifier],++    -- | Did installing work ok?+    installOutcome  :: InstallOutcome,++    --   Which version of the Cabal library was used to compile the Setup.hs+--    cabalVersion    :: Version,++    --   Which build tools we were using (with versions)+--    tools      :: [PackageIdentifier],++    -- | Configure outcome, did configure work ok?+    docsOutcome     :: Outcome,++    -- | Configure outcome, did configure work ok?+    testsOutcome    :: Outcome+  }++data InstallOutcome+   = DependencyFailed PackageIdentifier+   | DownloadFailed+   | UnpackFailed+   | SetupFailed+   | ConfigureFailed+   | BuildFailed+   | InstallFailed+   | InstallOk++data Outcome = NotTried | Failed | Ok++new :: OS -> Arch -> CompilerId -- -> Version+    -> ConfiguredPackage -> BR.BuildResult+    -> BuildReport+new os' arch' comp (ConfiguredPackage pkg flags deps) result =+  BuildReport {+    package               = packageId pkg,+    os                    = os',+    arch                  = arch',+    compiler              = comp,+    client                = cabalInstallID,+    flagAssignment        = flags,+    dependencies          = deps,+    installOutcome        = convertInstallOutcome,+--    cabalVersion          = undefined+    docsOutcome           = convertDocsOutcome,+    testsOutcome          = convertTestsOutcome+  }+  where+    cabalInstallID =+      PackageIdentifier "cabal-install" Paths_cabal_install.version++    convertInstallOutcome = case result of+      Left  (BR.DependentFailed p) -> DependencyFailed p+      Left  (BR.UnpackFailed    _) -> UnpackFailed+      Left  (BR.ConfigureFailed _) -> ConfigureFailed+      Left  (BR.BuildFailed     _) -> BuildFailed+      Left  (BR.InstallFailed   _) -> InstallFailed+      Right (BR.BuildOk       _ _) -> InstallOk+    convertDocsOutcome = case result of+      Left _                                -> NotTried+      Right (BR.BuildOk BR.DocsNotTried _)  -> NotTried+      Right (BR.BuildOk BR.DocsFailed _)    -> Failed+      Right (BR.BuildOk BR.DocsOk _)        -> Ok+    convertTestsOutcome = case result of+      Left _                                -> NotTried+      Right (BR.BuildOk _ BR.TestsNotTried) -> NotTried+      Right (BR.BuildOk _ BR.TestsFailed)   -> Failed+      Right (BR.BuildOk _ BR.TestsOk)       -> Ok++-- ------------------------------------------------------------+-- * External format+-- ------------------------------------------------------------++initialBuildReport :: BuildReport+initialBuildReport = BuildReport {+    package         = requiredField "package",+    os              = requiredField "os",+    arch            = requiredField "arch",+    compiler        = requiredField "compiler",+    client          = requiredField "client",+    flagAssignment  = [],+    dependencies    = [],+    installOutcome  = requiredField "install-outcome",+--    cabalVersion  = Nothing,+--    tools         = [],+    docsOutcome     = NotTried,+    testsOutcome    = NotTried+  }+  where+    requiredField fname = error ("required field: " ++ fname)++-- -----------------------------------------------------------------------------+-- Parsing++parse :: String -> Either String BuildReport+parse s = case parseFields s of+  ParseFailed perror -> Left  msg where (_, msg) = locatedErrorMsg perror+  ParseOk   _ report -> Right report++--FIXME: this does not allow for optional or repeated fields+parseFields :: String -> ParseResult BuildReport+parseFields input = do+  fields <- mapM extractField =<< readFields input+  let merged = mergeBy (\desc (_,name,_) -> compare (fieldName desc) name)+                       sortedFieldDescrs+                       (sortBy (comparing (\(_,name,_) -> name)) fields)+  checkMerged initialBuildReport merged++  where+    extractField :: Field -> ParseResult (Int, String, String)+    extractField (F line name value)  = return (line, name, value)+    extractField (Section line _ _ _) = syntaxError line "Unrecognized stanza"+    extractField (IfBlock line _ _ _) = syntaxError line "Unrecognized stanza"++    checkMerged report [] = return report+    checkMerged report (merged:remaining) = case merged of+      InBoth fieldDescr (line, _name, value) -> do+        report' <- fieldSet fieldDescr line value report+        checkMerged report' remaining+      OnlyInRight (line, name, _) ->+        syntaxError line ("Unrecognized field " ++ name)+      OnlyInLeft  fieldDescr ->+        fail ("Missing field " ++ fieldName fieldDescr)++parseList :: String -> [BuildReport]+parseList str =+  [ report | Right report <- map parse (split str) ]++  where+    split :: String -> [String]+    split = filter (not . null) . unfoldr chunk . lines+    chunk [] = Nothing+    chunk ls = case break null ls of+                 (r, rs) -> Just (unlines r, dropWhile null rs)++-- -----------------------------------------------------------------------------+-- Pretty-printing++show :: BuildReport -> String+show br = Disp.render (ppFields br fieldDescrs)++-- -----------------------------------------------------------------------------+-- Description of the fields, for parsing/printing++fieldDescrs :: [FieldDescr BuildReport]+fieldDescrs =+ [ simpleField "package"         Text.disp      Text.parse+                                 package        (\v r -> r { package = v })+ , simpleField "os"              Text.disp      Text.parse+                                 os             (\v r -> r { os = v })+ , simpleField "arch"            Text.disp      Text.parse+                                 arch           (\v r -> r { arch = v })+ , simpleField "compiler"        Text.disp      Text.parse+                                 compiler       (\v r -> r { compiler = v })+ , simpleField "client"          Text.disp      Text.parse+                                 client         (\v r -> r { client = v })+ , listField   "flags"           dispFlag       parseFlag+                                 flagAssignment (\v r -> r { flagAssignment = v })+ , listField   "dependencies"    Text.disp      Text.parse+                                 dependencies   (\v r -> r { dependencies = v })+ , simpleField "install-outcome" Text.disp      Text.parse+                                 installOutcome (\v r -> r { installOutcome = v })+ , simpleField "docs-outcome"    Text.disp      Text.parse+                                 docsOutcome    (\v r -> r { docsOutcome = v })+ , simpleField "tests-outcome"   Text.disp      Text.parse+                                 testsOutcome   (\v r -> r { testsOutcome = v })+ ]++sortedFieldDescrs :: [FieldDescr BuildReport]+sortedFieldDescrs = sortBy (comparing fieldName) fieldDescrs++dispFlag :: (FlagName, Bool) -> Disp.Doc+dispFlag (FlagName name, True)  =                  Disp.text name+dispFlag (FlagName name, False) = Disp.char '-' <> Disp.text name++parseFlag :: Parse.ReadP r (FlagName, Bool)+parseFlag = do+  name <- Parse.munch1 (\c -> Char.isAlphaNum c || c == '_' || c == '-')+  case name of+    ('-':flag) -> return (FlagName flag, False)+    flag       -> return (FlagName flag, True)++instance Text.Text InstallOutcome where+  disp (DependencyFailed pkgid) = Disp.text "DependencyFailed" <+> Text.disp pkgid+  disp DownloadFailed  = Disp.text "DownloadFailed"+  disp UnpackFailed    = Disp.text "UnpackFailed"+  disp SetupFailed     = Disp.text "SetupFailed"+  disp ConfigureFailed = Disp.text "ConfigureFailed"+  disp BuildFailed     = Disp.text "BuildFailed"+  disp InstallFailed   = Disp.text "InstallFailed"+  disp InstallOk       = Disp.text "InstallOk"++  parse = do+    name <- Parse.munch1 Char.isAlphaNum+    case name of+      "DependencyFailed" -> do Parse.skipSpaces+                               pkgid <- Text.parse+                               return (DependencyFailed pkgid)+      "DownloadFailed"   -> return DownloadFailed+      "UnpackFailed"     -> return UnpackFailed+      "SetupFailed"      -> return SetupFailed+      "ConfigureFailed"  -> return ConfigureFailed+      "BuildFailed"      -> return BuildFailed+      "InstallFailed"    -> return InstallFailed+      "InstallOk"        -> return InstallOk+      _                  -> Parse.pfail++instance Text.Text Outcome where+  disp NotTried = Disp.text "NotTried"+  disp Failed   = Disp.text "Failed"+  disp Ok       = Disp.text "Ok"+  parse = do+    name <- Parse.munch1 Char.isAlpha+    case name of+      "NotTried" -> return NotTried+      "Failed"   -> return Failed+      "Ok"       -> return Ok+      _          -> Parse.pfail
+ Distribution/Client/BuildReports/Storage.hs view
@@ -0,0 +1,117 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Reporting+-- Copyright   :  (c) David Waern 2008+-- License     :  BSD-like+--+-- Maintainer  :  david.waern@gmail.com+-- Stability   :  experimental+-- Portability :  portable+--+-- Anonymous build report data structure, printing and parsing+--+-----------------------------------------------------------------------------+module Distribution.Client.BuildReports.Storage (++    -- * Storing and retrieving build reports+    storeAnonymous,+    storeLocal,+--    retrieve,++    -- * 'InstallPlan' support+    fromInstallPlan,+  ) where++import qualified Distribution.Client.BuildReports.Anonymous as BuildReport+import Distribution.Client.BuildReports.Anonymous (BuildReport)++import Distribution.Client.Types+         ( ConfiguredPackage(..), AvailablePackage(..)+         , AvailablePackageSource(..), Repo(..), RemoteRepo(..) )+import qualified Distribution.Client.InstallPlan as InstallPlan+import Distribution.Client.InstallPlan+         ( InstallPlan, PlanPackage )+import Distribution.Client.Config+         ( defaultLogsDir )++import Distribution.System+         ( OS, Arch )+import Distribution.Compiler+         ( CompilerId )+import Distribution.Simple.Utils+         ( comparing, equating )++import Data.List+         ( groupBy, sortBy )+import Data.Maybe+         ( catMaybes )+import System.FilePath+         ( (</>) )+import System.Directory+         ( createDirectoryIfMissing )++storeAnonymous :: [(BuildReport, Repo)] -> IO ()+storeAnonymous reports = sequence_+  [ appendFile file (concatMap format reports')+  | (repo, reports') <- separate reports+  , let file = repoLocalDir repo </> "build-reports.log" ]+  --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)++  where+    format r = '\n' : BuildReport.show r ++ "\n"+    separate :: [(BuildReport, Repo)]+             -> [(Repo, [BuildReport])]+    separate = map (\rs@((_,repo,_):_) -> (repo, [ r | (r,_,_) <- rs ]))+             . map concat+             . groupBy (equating (repoName . head))+             . sortBy (comparing (repoName . head))+             . groupBy (equating repoName)+             . onlyRemote+    repoName (_,_,rrepo) = remoteRepoName rrepo++    onlyRemote :: [(BuildReport, Repo)] -> [(BuildReport, Repo, RemoteRepo)]+    onlyRemote rs =+      [ (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)++  where+    format r = '\n' : BuildReport.show r ++ "\n"+++-- ------------------------------------------------------------+-- * InstallPlan support+-- ------------------------------------------------------------++fromInstallPlan :: InstallPlan -> [(BuildReport, Repo)]+fromInstallPlan plan = catMaybes+                     . map (fromPlanPackage os' arch' comp)+                     . InstallPlan.toList+                     $ plan+  where os'   = InstallPlan.planOS plan+        arch' = InstallPlan.planArch plan+        comp  = InstallPlan.planCompiler plan++fromPlanPackage :: OS -> Arch -> CompilerId+                -> InstallPlan.PlanPackage+                -> Maybe (BuildReport, Repo)+fromPlanPackage os' arch' comp planPackage = case planPackage of++  InstallPlan.Installed pkg@(ConfiguredPackage (AvailablePackage {+                          packageSource = RepoTarballPackage repo }) _ _) result+    -> 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)++  _ -> Nothing
+ Distribution/Client/BuildReports/Upload.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE PatternGuards #-}+-- This is a quick hack for uploading build reports to Hackage.++module Distribution.Client.BuildReports.Upload+    ( BuildLog+    , BuildReportId+    , uploadReports+    , postBuildReport+    , putBuildLog+    ) where++import Network.Browser+         ( BrowserAction, request, setAllowRedirects )+import Network.HTTP+         ( Header(..), HeaderName(..)+         , Request(..), RequestMethod(..), Response(..) )+import Network.URI (URI, uriPath, parseRelativeReference, relativeTo)++import Control.Monad+         ( forM_ )+import System.FilePath.Posix+         ( (</>) )+import qualified Distribution.Client.BuildReports.Anonymous as BuildReport+import Distribution.Client.BuildReports.Anonymous (BuildReport)++type BuildReportId = URI+type BuildLog = String++uploadReports :: URI -> [(BuildReport, Maybe BuildLog)] ->  BrowserAction ()+uploadReports uri reports+    = forM_ reports $ \(report, mbBuildLog) ->+      do buildId <- postBuildReport uri report+         case mbBuildLog of+           Just buildLog -> putBuildLog buildId buildLog+           Nothing       -> return ()++postBuildReport :: URI -> BuildReport -> BrowserAction BuildReportId+postBuildReport uri buildReport = do+  setAllowRedirects False+  (_, response) <- request Request {+    rqURI     = uri { uriPath = "/buildreports" },+    rqMethod  = POST,+    rqHeaders = [Header HdrContentType   ("text/plain"),+                 Header HdrContentLength (show (length body)),+                 Header HdrAccept        ("text/plain")],+    rqBody    = body+  }+  case rspCode response of+    (3,0,3) | [Just buildId] <- [ do rel <- parseRelativeReference location+                                     relativeTo rel uri+                                  | Header HdrLocation location <- rspHeaders response ]+              -> return $ buildId+    _         -> error "Unrecognised response from server."+  where body  = BuildReport.show buildReport++putBuildLog :: BuildReportId -> BuildLog -> BrowserAction ()+putBuildLog reportId buildLog = do+  --FIXME: do something if the request fails+  (_, response) <- request Request {+      rqURI     = reportId{uriPath = uriPath reportId </> "buildlog"},+      rqMethod  = PUT,+      rqHeaders = [Header HdrContentType   ("text/plain"),+                   Header HdrContentLength (show (length buildLog)),+                   Header HdrAccept        ("text/plain")],+      rqBody    = buildLog+    }+  return ()
+ Distribution/Client/Check.hs view
@@ -0,0 +1,81 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Check+-- Copyright   :  (c) Lennart Kolmodin 2008+-- License     :  BSD-like+--+-- Maintainer  :  kolmodin@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- Check a package for common mistakes+--+-----------------------------------------------------------------------------+module Distribution.Client.Check (+    check+  ) where++import Control.Monad ( when, unless )++import Distribution.PackageDescription ( readPackageDescription )+import Distribution.PackageDescription.Check+import Distribution.PackageDescription.Configuration ( flattenPackageDescription )+import Distribution.Verbosity ( Verbosity )+import Distribution.Simple.Utils ( defaultPackageDesc, toUTF8 )++check :: Verbosity -> IO Bool+check verbosity = do+    pdfile <- defaultPackageDesc verbosity+    ppd <- readPackageDescription verbosity pdfile+    -- flatten the generic package description into a regular package+    -- description+    -- TODO: this may give more warnings than it should give;+    --       consider two branches of a condition, one saying+    --          ghc-options: -Wall+    --       and the other+    --          ghc-options: -Werror+    --      joined into+    --          ghc-options: -Wall -Werror+    --      checkPackages will yield a warning on the last line, but it+    --      would not on each individual branch.+    --      Hovever, this is the same way hackage does it, so we will yield+    --      the exact same errors as it will.+    let pkg_desc = flattenPackageDescription ppd+    ioChecks <- checkPackageFiles pkg_desc "."+    let packageChecks = ioChecks ++ checkPackage ppd (Just pkg_desc)+        buildImpossible = [ x | x@PackageBuildImpossible {} <- packageChecks ]+        buildWarning    = [ x | x@PackageBuildWarning {}    <- packageChecks ]+        distSuspicious  = [ x | x@PackageDistSuspicious {}  <- packageChecks ]+        distInexusable  = [ x | x@PackageDistInexcusable {} <- packageChecks ]++    unless (null buildImpossible) $ do+        putStrLn "The package will not build sanely due to these errors:"+        mapM_ (putStrLn . toUTF8. explanation) buildImpossible+        putStrLn ""++    unless (null buildWarning) $ do+        putStrLn "The following warnings are likely affect your build negatively:"+        mapM_ (putStrLn . toUTF8 . explanation) buildWarning+        putStrLn ""++    unless (null distSuspicious) $ do+        putStrLn "These warnings may cause trouble when distributing the package:"+        mapM_ (putStrLn . toUTF8 . explanation) distSuspicious+        putStrLn ""++    unless (null distInexusable) $ do+        putStrLn "The following errors will cause portability problems on other environments:"+        mapM_ (putStrLn . toUTF8 . explanation) distInexusable+        putStrLn ""++    let isDistError (PackageDistSuspicious {}) = False+        isDistError _                          = True+        errors = filter isDistError packageChecks++    unless (null errors) $ do+        putStrLn "Hackage would reject this package."++    when (null packageChecks) $ do+        putStrLn "No errors or warnings could be found in the package."++    return (null packageChecks)
+ Distribution/Client/Config.hs view
@@ -0,0 +1,508 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Config+-- Copyright   :  (c) David Himmelstrup 2005+-- License     :  BSD-like+--+-- Maintainer  :  lemmih@gmail.com+-- Stability   :  provisional+-- Portability :  portable+--+-- Utilities for handling saved state such as known packages, known servers and downloaded packages.+-----------------------------------------------------------------------------+module Distribution.Client.Config (+    SavedConfig(..),+    loadConfig,++    showConfig,+    showConfigWithComments,+    parseConfig,++    defaultCabalDir,+    defaultCacheDir,+    defaultLogsDir,+  ) where+++import Distribution.Client.Types+         ( RemoteRepo(..), Username(..), Password(..) )+import Distribution.Client.Setup+         ( GlobalFlags(..), globalCommand+         , InstallFlags(..), installOptions, defaultInstallFlags+         , UploadFlags(..), uploadCommand+         , showRepo, parseRepo )++import Distribution.Simple.Setup+         ( ConfigFlags(..), configureOptions, defaultConfigFlags+         , Flag, toFlag, flagToMaybe, fromFlagOrDefault, flagToList )+import Distribution.Simple.InstallDirs+         ( InstallDirs(..), defaultInstallDirs+         , PathTemplate, toPathTemplate, fromPathTemplate )+import Distribution.ParseUtils+         ( FieldDescr(..), liftField+         , ParseResult(..), locatedErrorMsg, showPWarning+         , readFields, warning, lineNo+         , simpleField, listField, parseFilePathQ, parseTokenQ )+import qualified Distribution.ParseUtils as ParseUtils+         ( Field(..) )+import Distribution.ReadE+         ( succeedReadE )+import Distribution.Simple.Command+         ( CommandUI(commandOptions), commandDefaultFlags, ShowOrParseArgs(..)+         , viewAsFieldDescr, OptionField, option, reqArg )+import Distribution.Simple.Program+         ( defaultProgramConfiguration )+import Distribution.Simple.Utils+         ( notice, warn, lowercase )+import Distribution.Compiler+         ( CompilerFlavor(..), defaultCompilerFlavor )+import Distribution.System+         ( OS(Windows), buildOS )+import Distribution.Verbosity+         ( Verbosity, normal )++import Data.List+         ( partition )+import Data.Maybe+         ( fromMaybe )+import Data.Monoid+         ( Monoid(..) )+import Control.Monad+         ( when, foldM )+import qualified Data.Map as Map+import qualified Distribution.Compat.ReadP as Parse+         ( option )+import qualified Text.PrettyPrint.HughesPJ as Disp+         ( Doc, render, text, colon, vcat, isEmpty, nest )+import Text.PrettyPrint.HughesPJ+         ( (<>), (<+>), ($$), ($+$) )+import System.Directory+         ( createDirectoryIfMissing, getAppUserDataDirectory )+import Network.URI+         ( URI(..), URIAuth(..) )+import System.FilePath+         ( (</>), takeDirectory )+import System.IO.Error+         ( isDoesNotExistError )++--+-- * Configuration saved in the config file+--++data SavedConfig = SavedConfig {+    savedGlobalFlags       :: GlobalFlags,+    savedInstallFlags      :: InstallFlags,+    savedConfigureFlags    :: ConfigFlags,+    savedUserInstallDirs   :: InstallDirs (Flag PathTemplate),+    savedGlobalInstallDirs :: InstallDirs (Flag PathTemplate),+    savedUploadFlags       :: UploadFlags+  }++instance Monoid SavedConfig where+  mempty = SavedConfig {+    savedGlobalFlags       = mempty,+    savedInstallFlags      = mempty,+    savedConfigureFlags    = mempty,+    savedUserInstallDirs   = mempty,+    savedGlobalInstallDirs = mempty,+    savedUploadFlags       = mempty+  }+  mappend a b = SavedConfig {+    savedGlobalFlags       = combine savedGlobalFlags,+    savedInstallFlags      = combine savedInstallFlags,+    savedConfigureFlags    = combine savedConfigureFlags,+    savedUserInstallDirs   = combine savedUserInstallDirs,+    savedGlobalInstallDirs = combine savedGlobalInstallDirs,+    savedUploadFlags       = combine savedUploadFlags+  }+    where combine field = field a `mappend` field b++updateInstallDirs :: Flag Bool -> SavedConfig -> SavedConfig+updateInstallDirs userInstallFlag+  savedConfig@SavedConfig {+    savedConfigureFlags    = configureFlags,+    savedUserInstallDirs   = userInstallDirs,+    savedGlobalInstallDirs = globalInstallDirs+  } =+  savedConfig {+    savedConfigureFlags = configureFlags {+      configInstallDirs = installDirs+    }+  }+  where+    installDirs | userInstall = userInstallDirs+                | otherwise   = globalInstallDirs+    userInstall = fromFlagOrDefault defaultUserInstall $+                    configUserInstall configureFlags `mappend` userInstallFlag++--+-- * Default config+--++-- | These are the absolute basic defaults. The fields that must be+-- initialised. When we load the config from the file we layer the loaded+-- values over these ones, so any missing fields in the file take their values+-- from here.+--+baseSavedConfig :: IO SavedConfig+baseSavedConfig = do+  userPrefix <- defaultCabalDir+  return mempty {+    savedConfigureFlags  = mempty {+      configHcFlavor     = toFlag defaultCompiler,+      configUserInstall  = toFlag defaultUserInstall,+      configVerbosity    = toFlag normal+    },+    savedUserInstallDirs = mempty {+      prefix             = toFlag (toPathTemplate userPrefix)+    }+  }++-- | This is the initial configuration that we write out to to the config file+-- if the file does not exist (or the config we use if the file cannot be read+-- for some other reason). When the config gets loaded it gets layered on top+-- of 'baseSavedConfig' so we do not need to include it into the initial+-- values we save into the config file.+--+initialSavedConfig :: IO SavedConfig+initialSavedConfig = do+  cacheDir   <- defaultCacheDir+  return mempty {+    savedGlobalFlags     = mempty {+      globalCacheDir     = toFlag cacheDir,+      globalRemoteRepos  = [defaultRemoteRepo]+    }+  }++defaultCabalDir :: IO FilePath+defaultCabalDir = getAppUserDataDirectory "cabal"++defaultConfigFile :: IO FilePath+defaultConfigFile = do+  dir <- defaultCabalDir+  return $ dir </> "config"++defaultCacheDir :: IO FilePath+defaultCacheDir = do+  dir <- defaultCabalDir+  return $ dir </> "packages"++defaultLogsDir :: IO FilePath+defaultLogsDir = do+  dir <- defaultCabalDir+  return $ dir </> "logs"++defaultCompiler :: CompilerFlavor+defaultCompiler = fromMaybe GHC defaultCompilerFlavor++defaultUserInstall :: Bool+defaultUserInstall = case buildOS of+  -- We do global installs by default on Windows+  Windows -> False+  -- and per-user installs by default everywhere else+  _       -> True++defaultRemoteRepo :: RemoteRepo+defaultRemoteRepo = RemoteRepo name uri+  where+    name = "hackage.haskell.org"+    uri  = URI "http:" (Just (URIAuth "" name "")) "/packages/archive" "" ""++--+-- * Config file reading+--++loadConfig :: Verbosity -> Flag FilePath -> Flag Bool -> IO SavedConfig+loadConfig verbosity configFileFlag userInstallFlag = addBaseConf $ do+  configFile <- maybe defaultConfigFile return (flagToMaybe configFileFlag)++  minp <- readConfigFile mempty configFile+  case minp of+    Nothing -> do+      notice verbosity $ "Config file " ++ configFile ++ " not found."+      notice verbosity $ "Writing default configuration to " ++ configFile+      commentConf <- commentSavedConfig+      initialConf <- initialSavedConfig+      writeConfigFile configFile commentConf initialConf+      return initialConf+    Just (ParseOk ws conf) -> do+      when (not $ null ws) $ warn verbosity $+        unlines (map (showPWarning configFile) ws)+      return conf+    Just (ParseFailed err) -> do+      let (line, msg) = locatedErrorMsg err+      warn verbosity $+          "Error parsing config file " ++ configFile+        ++ maybe "" (\n -> ":" ++ show n) line ++ ": " ++ show msg+      warn verbosity $ "Using default configuration."+      initialSavedConfig++  where+    addBaseConf body = do+      base  <- baseSavedConfig+      extra <- body+      return (updateInstallDirs userInstallFlag (base `mappend` extra))++readConfigFile :: SavedConfig -> FilePath -> IO (Maybe (ParseResult SavedConfig))+readConfigFile initial file = handleNotExists $+  fmap (Just . parseConfig initial) (readFile file)++  where+    handleNotExists action = catch action $ \ioe ->+      if isDoesNotExistError ioe+        then return Nothing+        else ioError ioe++writeConfigFile :: FilePath -> SavedConfig -> SavedConfig -> IO ()+writeConfigFile file comments vals = do+  createDirectoryIfMissing True (takeDirectory file)+  writeFile file $ showConfigWithComments comments vals ++ "\n"++-- | 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+-- initial config file so that the user can see what default value they are+-- overriding.+--+commentSavedConfig :: IO SavedConfig+commentSavedConfig = do+  userInstallDirs   <- defaultInstallDirs defaultCompiler True True+  globalInstallDirs <- defaultInstallDirs defaultCompiler False True+  return SavedConfig {+    savedGlobalFlags       = commandDefaultFlags globalCommand,+    savedInstallFlags      = defaultInstallFlags,+    savedConfigureFlags    = (defaultConfigFlags defaultProgramConfiguration) {+      configUserInstall    = toFlag defaultUserInstall+    },+    savedUserInstallDirs   = fmap toFlag userInstallDirs,+    savedGlobalInstallDirs = fmap toFlag globalInstallDirs,+    savedUploadFlags       = commandDefaultFlags uploadCommand+  }++-- | All config file fields.+--+configFieldDescriptions :: [FieldDescr SavedConfig]+configFieldDescriptions =++     toSavedConfig liftGlobalFlag+       (commandOptions globalCommand ParseArgs)+       ["version", "numeric-version", "config-file"]++  ++ toSavedConfig liftInstallFlag+       (installOptions ParseArgs)+       ["dry-run", "reinstall", "only"]++  ++ toSavedConfig liftConfigFlag+       (configureOptions ParseArgs)+       (["scratchdir", "configure-option"] ++ map fieldName installDirsFields)++  ++ toSavedConfig liftUploadFlag+       (commandOptions uploadCommand ParseArgs)+       ["verbose", "check"]++  where+    toSavedConfig lift options excluded =+      [ lift field+      | opt <- options+      , let field = viewAsFieldDescr opt+      , fieldName field `notElem` excluded ]++-- TODO: next step, make the deprecated fields elicit a warning.+--+deprecatedFieldDescriptions :: [FieldDescr SavedConfig]+deprecatedFieldDescriptions =+  [ liftGlobalFlag $+    listField "repos"+      (Disp.text . showRepo) parseRepo+      globalRemoteRepos (\rs cfg -> cfg { globalRemoteRepos = rs })+  , liftGlobalFlag $+    simpleField "cachedir"+      (Disp.text . fromFlagOrDefault "") (optional parseFilePathQ)+      globalCacheDir    (\d cfg -> cfg { globalCacheDir = d })+  , liftUploadFlag $+    simpleField "hackage-username"+      (Disp.text . fromFlagOrDefault "" . fmap unUsername)+      (optional (fmap Username parseTokenQ))+      uploadUsername    (\d cfg -> cfg { uploadUsername = d })+  , liftUploadFlag $+    simpleField "hackage-password"+      (Disp.text . fromFlagOrDefault "" . fmap unPassword)+      (optional (fmap Password parseTokenQ))+      uploadPassword    (\d cfg -> cfg { uploadPassword = d })+  ]+ ++ map (modifyFieldName ("user-"++)   . liftUserInstallDirs)   installDirsFields+ ++ map (modifyFieldName ("global-"++) . liftGlobalInstallDirs) installDirsFields+  where+    optional = Parse.option mempty . fmap toFlag+    modifyFieldName :: (String -> String) -> FieldDescr a -> FieldDescr a+    modifyFieldName f d = d { fieldName = f (fieldName d) }++liftUserInstallDirs :: FieldDescr (InstallDirs (Flag PathTemplate))+                    -> FieldDescr SavedConfig+liftUserInstallDirs = liftField+  savedUserInstallDirs (\flags conf -> conf { savedUserInstallDirs = flags })++liftGlobalInstallDirs :: FieldDescr (InstallDirs (Flag PathTemplate))+                      -> FieldDescr SavedConfig+liftGlobalInstallDirs = liftField+  savedGlobalInstallDirs (\flags conf -> conf { savedGlobalInstallDirs = flags })++liftGlobalFlag :: FieldDescr GlobalFlags -> FieldDescr SavedConfig+liftGlobalFlag = liftField+  savedGlobalFlags (\flags conf -> conf { savedGlobalFlags = flags })++liftConfigFlag :: FieldDescr ConfigFlags -> FieldDescr SavedConfig+liftConfigFlag = liftField+  savedConfigureFlags (\flags conf -> conf { savedConfigureFlags = flags })++liftInstallFlag :: FieldDescr InstallFlags -> FieldDescr SavedConfig+liftInstallFlag = liftField+  savedInstallFlags (\flags conf -> conf { savedInstallFlags = flags })++liftUploadFlag :: FieldDescr UploadFlags -> FieldDescr SavedConfig+liftUploadFlag = liftField+  savedUploadFlags (\flags conf -> conf { savedUploadFlags = flags })++parseConfig :: SavedConfig -> String -> ParseResult SavedConfig+parseConfig initial = \str -> do+  fields <- readFields str+  let (knownSections, others) = partition isKnownSection fields+  config <- parse others+  (user, global) <- foldM parseSections (mempty, mempty) knownSections+  return config {+    savedUserInstallDirs   = user,+    savedGlobalInstallDirs = global+  }++  where+    isKnownSection (ParseUtils.Section _ "install-dirs" _ _) = True+    isKnownSection _                                          = False++    parse = parseFields (configFieldDescriptions+                      ++ deprecatedFieldDescriptions) initial++    parseSections accum@(u,g) (ParseUtils.Section _ "install-dirs" name fs)+      | name' == "user"   = do u' <- parseFields installDirsFields u fs+                               return (u', g)+      | name' == "global" = do g' <- parseFields installDirsFields g fs+                               return (u, g')+      | otherwise         = do+          warning "The install-paths section should be for 'user' or 'global'"+          return accum+      where name' = lowercase name+    parseSections accum f = do+      warning $ "Unrecognized stanza on line " ++ show (lineNo f)+      return accum++showConfig :: SavedConfig -> String+showConfig = showConfigWithComments mempty++showConfigWithComments :: SavedConfig -> SavedConfig -> String+showConfigWithComments comment vals = Disp.render $+      ppFields configFieldDescriptions comment vals+  $+$ Disp.text ""+  $+$ installDirsSection "user"   savedUserInstallDirs+  $+$ Disp.text ""+  $+$ installDirsSection "global" savedGlobalInstallDirs+  where+    installDirsSection name field =+      ppSection "install-dirs" name installDirsFields+                (field comment) (field vals)++------------------------+-- * Parsing utils+--++--FIXME: replace this with something better in Cabal-1.5+parseFields :: [FieldDescr a] -> a -> [ParseUtils.Field] -> ParseResult a+parseFields fields initial = foldM setField initial+  where+    fieldMap = Map.fromList+      [ (name, f) | f@(FieldDescr name _ _) <- fields ]+    setField accum (ParseUtils.F line name value) = case Map.lookup name fieldMap of+      Just (FieldDescr _ _ set) -> set line value accum+      Nothing -> do+        warning $ "Unrecognized field " ++ name ++ " on line " ++ show line+        return accum+    setField accum f = do+      warning $ "Unrecognized stanza on line " ++ show (lineNo f)+      return accum++-- | This is a customised version of the function from Cabal that also prints+-- default values for empty fields as comments.+--+ppFields :: [FieldDescr a] -> a -> a -> Disp.Doc+ppFields fields def cur = Disp.vcat [ ppField name (getter def) (getter cur)+                                    | FieldDescr name getter _ <- fields]++ppField :: String -> Disp.Doc -> Disp.Doc -> Disp.Doc+ppField name def cur+  | Disp.isEmpty cur = Disp.text "--" <+> Disp.text name <> Disp.colon <+> def+  | otherwise        =                    Disp.text name <> Disp.colon <+> cur++ppSection :: String -> String -> [FieldDescr a] -> a -> a -> Disp.Doc+ppSection name arg fields def cur =+     Disp.text name <+> Disp.text arg+  $$ Disp.nest 2 (ppFields fields def cur)++installDirsFields :: [FieldDescr (InstallDirs (Flag PathTemplate))]+installDirsFields = map viewAsFieldDescr installDirsOptions++--TODO: this is now exported in Cabal-1.5+installDirsOptions :: [OptionField (InstallDirs (Flag PathTemplate))]+installDirsOptions =+  [ option "" ["prefix"]+      "bake this prefix in preparation of installation"+      prefix (\v flags -> flags { prefix = v })+      installDirArg++  , option "" ["bindir"]+      "installation directory for executables"+      bindir (\v flags -> flags { bindir = v })+      installDirArg++  , option "" ["libdir"]+      "installation directory for libraries"+      libdir (\v flags -> flags { libdir = v })+      installDirArg++  , option "" ["libsubdir"]+      "subdirectory of libdir in which libs are installed"+      libsubdir (\v flags -> flags { libsubdir = v })+      installDirArg++  , option "" ["libexecdir"]+      "installation directory for program executables"+      libexecdir (\v flags -> flags { libexecdir = v })+      installDirArg++  , option "" ["datadir"]+      "installation directory for read-only data"+      datadir (\v flags -> flags { datadir = v })+      installDirArg++  , option "" ["datasubdir"]+      "subdirectory of datadir in which data files are installed"+      datasubdir (\v flags -> flags { datasubdir = v })+      installDirArg++  , option "" ["docdir"]+      "installation directory for documentation"+      docdir (\v flags -> flags { docdir = v })+      installDirArg++  , option "" ["htmldir"]+      "installation directory for HTML documentation"+      htmldir (\v flags -> flags { htmldir = v })+      installDirArg++  , option "" ["haddockdir"]+      "installation directory for haddock interfaces"+      haddockdir (\v flags -> flags { haddockdir = v })+      installDirArg+  ]+  where+    installDirArg _sf _lf d get set =+      reqArgFlag "DIR" _sf _lf d+        (fmap fromPathTemplate . get) (set . fmap toPathTemplate)++    reqArgFlag ad = reqArg ad (succeedReadE toFlag) flagToList
+ Distribution/Client/Dependency.hs view
@@ -0,0 +1,179 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Dependency+-- Copyright   :  (c) David Himmelstrup 2005,+--                    Bjorn Bringert 2007+--                    Duncan Coutts 2008+-- License     :  BSD-like+--+-- Maintainer  :  cabal-devel@gmail.com+-- Stability   :  provisional+-- Portability :  portable+--+-- Top level interface to dependency resolution.+-----------------------------------------------------------------------------+module Distribution.Client.Dependency (+    resolveDependencies,+    resolveDependenciesWithProgress,+    PackagesVersionPreference(..),+    upgradableDependencies,+  ) where++import Distribution.Client.Dependency.Bogus (bogusResolver)+import Distribution.Client.Dependency.TopDown (topDownResolver)+import qualified Distribution.Simple.PackageIndex as PackageIndex+import Distribution.Simple.PackageIndex (PackageIndex)+import Distribution.InstalledPackageInfo (InstalledPackageInfo)+import qualified Distribution.Client.InstallPlan as InstallPlan+import Distribution.Client.InstallPlan (InstallPlan)+import Distribution.Client.Types+         ( UnresolvedDependency(..), AvailablePackage(..) )+import Distribution.Client.Dependency.Types+         ( PackageName, DependencyResolver, PackageVersionPreference(..)+         , Progress(..), foldProgress )+import Distribution.Package+         ( PackageIdentifier(..), packageVersion, packageName+         , Dependency(..), Package(..), PackageFixedDeps(..) )+import Distribution.Version+         ( orLaterVersion )+import Distribution.Compiler+         ( CompilerId )+import Distribution.System+         ( OS, Arch )+import Distribution.Simple.Utils (comparing)+import Distribution.Client.Utils (mergeBy, MergeResult(..))++import Data.List (maximumBy)+import Data.Monoid (Monoid(mempty))+import qualified Data.Set as Set+import Data.Set (Set)+import Control.Exception (assert)++defaultResolver :: DependencyResolver+defaultResolver = topDownResolver+--for the brave: try the new topDownResolver, but only with --dry-run !!!++-- | Global policy for the versions of all packages.+--+data PackagesVersionPreference =++     -- | Always prefer the latest version irrespective of any existing+     -- installed version.+     --+     -- * This is the standard policy for upgrade.+     --+     PreferAllLatest++     -- | Always prefer the installed versions over ones that would need to be+     -- installed. Secondarily, prefer latest versions (eg the latest installed+     -- version or if there are none then the latest available version).+   | PreferAllInstalled++     -- | Prefer the latest version for packages that are explicitly requested+     -- but prefers the installed version for any other packages.+     --+     -- * This is the standard policy for install.+     --+   | PreferLatestForSelected++resolveDependencies :: OS+                    -> Arch+                    -> CompilerId+                    -> Maybe (PackageIndex InstalledPackageInfo)+                    -> PackageIndex AvailablePackage+                    -> PackagesVersionPreference+                    -> [UnresolvedDependency]+                    -> Either String InstallPlan+resolveDependencies os arch comp installed available pref deps =+  foldProgress (flip const) Left Right $+    resolveDependenciesWithProgress os arch comp installed available pref deps++resolveDependenciesWithProgress :: OS+                                -> Arch+                                -> CompilerId+                                -> Maybe (PackageIndex InstalledPackageInfo)+                                -> PackageIndex AvailablePackage+                                -> PackagesVersionPreference+                                -> [UnresolvedDependency]+                                -> Progress String String InstallPlan+resolveDependenciesWithProgress os arch comp (Just installed) =+  dependencyResolver defaultResolver os arch comp installed++resolveDependenciesWithProgress os arch comp Nothing =+  dependencyResolver bogusResolver os arch comp mempty++hideBrokenPackages :: PackageFixedDeps p => PackageIndex p -> PackageIndex p+hideBrokenPackages index =+    check (null . PackageIndex.brokenPackages)+  . foldr (PackageIndex.deletePackageId . packageId) index+  . PackageIndex.reverseDependencyClosure index+  . map (packageId . fst)+  $ PackageIndex.brokenPackages index+  where+    check p x = assert (p x) x++hideBasePackage :: Package p => PackageIndex p -> PackageIndex p+hideBasePackage = PackageIndex.deletePackageName "base"+                . PackageIndex.deletePackageName "ghc-prim"++dependencyResolver+  :: DependencyResolver+  -> OS -> Arch -> CompilerId+  -> PackageIndex InstalledPackageInfo+  -> PackageIndex AvailablePackage+  -> PackagesVersionPreference+  -> [UnresolvedDependency]+  -> Progress String String InstallPlan+dependencyResolver resolver os arch comp installed available pref deps =+  let installed' = hideBrokenPackages installed+      available' = hideBasePackage available+   in fmap toPlan+    $ resolver os arch comp installed' available' preference deps++  where+    toPlan pkgs =+      case InstallPlan.new os arch 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 = interpretPackagesVersionPreference initialPkgNames pref+    initialPkgNames = Set.fromList+      [ name | UnresolvedDependency (Dependency name _) _ <- deps ]++-- | Give an interpretation to the global 'PackagesVersionPreference' as+--  specific per-package 'PackageVersionPreference'.+--+interpretPackagesVersionPreference :: Set PackageName+                                   -> PackagesVersionPreference+                                   -> (PackageName -> PackageVersionPreference)+interpretPackagesVersionPreference selected pref = case pref of+  PreferAllLatest         -> const PreferLatest+  PreferAllInstalled      -> const 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.+--+upgradableDependencies :: PackageIndex InstalledPackageInfo+                       -> PackageIndex AvailablePackage+                       -> [Dependency]+upgradableDependencies installed available =+  [ Dependency name (orLaterVersion latestVersion)+    -- This is really quick (linear time). The trick is that we're doing a+    -- merge join of two tables. We can do it as a merge because they're in+    -- a comparable order because we're getting them from the package indexs.+  | InBoth latestInstalled allAvailable+      <- mergeBy (\a (b:_) -> packageName a `compare` packageName b)+                 [ maximumBy (comparing packageVersion) pkgs+                 | pkgs <- PackageIndex.allPackagesByName installed ]+                 (PackageIndex.allPackagesByName available)+  , let (PackageIdentifier name latestVersion) = packageId latestInstalled+  , any (\p -> packageVersion p > latestVersion) allAvailable ]
+ Distribution/Client/Dependency/Bogus.hs view
@@ -0,0 +1,109 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Dependency.Bogus+-- Copyright   :  (c) David Himmelstrup 2005, Bjorn Bringert 2007+--                    Duncan Coutts 2008+-- License     :  BSD-like+--+-- Maintainer  :  cabal-devel@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- A dependency resolver for when we do not know what packages are installed.+-----------------------------------------------------------------------------+module Distribution.Client.Dependency.Bogus (+    bogusResolver+  ) where++import Distribution.Client.Types+         ( UnresolvedDependency(..), AvailablePackage(..)+         , ConfiguredPackage(..) )+import Distribution.Client.Dependency.Types+         ( DependencyResolver, Progress(..) )+import qualified Distribution.Client.InstallPlan as InstallPlan++import Distribution.Package+         ( PackageIdentifier(..), Dependency(..), Package(..) )+import Distribution.PackageDescription+         ( GenericPackageDescription(..), CondTree(..), FlagAssignment )+import Distribution.PackageDescription.Configuration+         ( finalizePackageDescription )+import qualified Distribution.Simple.PackageIndex as PackageIndex+import Distribution.Simple.PackageIndex (PackageIndex)+import Distribution.Version+         ( VersionRange(IntersectVersionRanges) )+import Distribution.Simple.Utils+         ( equating, comparing )+import Distribution.Text+         ( display )++import Data.List+         ( maximumBy, sortBy, groupBy )++-- | This resolver thinks that every package is already installed.+--+-- We need this for hugs and nhc98 which do not track installed packages.+-- We just pretend that everything is installed and hope for the best.+--+bogusResolver :: DependencyResolver+bogusResolver os arch comp _ available _ = resolveFromAvailable []+                                         . combineDependencies+  where+    resolveFromAvailable chosen [] = Done chosen+    resolveFromAvailable chosen (UnresolvedDependency dep flags : deps) =+      case latestAvailableSatisfying available dep of+        Nothing  -> Fail ("Unresolved dependency: " ++ display dep)+        Just apkg@(AvailablePackage _ pkg _) ->+          case finalizePackageDescription flags none os arch comp [] pkg of+            Right (_, flags') -> Step msg (resolveFromAvailable chosen' deps)+              where+                msg     = "selecting " ++ display (packageId pkg)+                cpkg    = fudgeChosenPackage apkg flags'+                chosen' = InstallPlan.Configured cpkg : chosen+            _ -> error "bogusResolver: impossible happened"+          where+            none :: Maybe (PackageIndex PackageIdentifier)+            none = Nothing++fudgeChosenPackage :: AvailablePackage -> FlagAssignment -> ConfiguredPackage+fudgeChosenPackage (AvailablePackage pkgid pkg source) flags =+  ConfiguredPackage (AvailablePackage pkgid (stripDependencies pkg) source)+                    flags ([] :: [PackageIdentifier]) -- empty list of deps+  where+    -- | Pretend that a package has no dependencies. Go through the+    -- 'GenericPackageDescription' and strip them all out.+    --+    stripDependencies :: GenericPackageDescription -> GenericPackageDescription+    stripDependencies gpkg = gpkg {+        condLibrary     = fmap stripDeps (condLibrary gpkg),+        condExecutables = [ (name, stripDeps tree)+                          | (name, tree) <- condExecutables gpkg ]+      }+    stripDeps :: CondTree v [Dependency] a -> CondTree v [Dependency] a+    stripDeps = mapTreeConstrs (const [])++    mapTreeConstrs :: (c -> c) -> CondTree v c a -> CondTree v c a+    mapTreeConstrs f (CondNode a c ifs) = CondNode a (f c) (map g ifs)+      where+        g (cnd, t, me) = (cnd, mapTreeConstrs f t, fmap (mapTreeConstrs f) me)++combineDependencies :: [UnresolvedDependency] -> [UnresolvedDependency]+combineDependencies = map combineGroup+                    . groupBy (equating depName)+                    . sortBy  (comparing depName)+  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++-- | Gets the latest available package satisfying a dependency.+latestAvailableSatisfying :: PackageIndex AvailablePackage+                          -> Dependency+                          -> Maybe AvailablePackage+latestAvailableSatisfying index dep =+  case PackageIndex.lookupDependency index dep of+    []   -> Nothing+    pkgs -> Just (maximumBy (comparing (pkgVersion . packageId)) pkgs)
+ Distribution/Client/Dependency/TopDown.hs view
@@ -0,0 +1,598 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Dependency.Types+-- Copyright   :  (c) Duncan Coutts 2008+-- License     :  BSD-like+--+-- Maintainer  :  cabal-devel@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- Common types for dependency resolution.+-----------------------------------------------------------------------------+module Distribution.Client.Dependency.TopDown (+    topDownResolver+  ) where++import Distribution.Client.Dependency.TopDown.Types+import qualified Distribution.Client.Dependency.TopDown.Constraints as Constraints+import Distribution.Client.Dependency.TopDown.Constraints+         ( Satisfiable(..) )+import qualified Distribution.Client.InstallPlan as InstallPlan+import Distribution.Client.InstallPlan+         ( PlanPackage(..) )+import Distribution.Client.Types+         ( UnresolvedDependency(..), AvailablePackage(..)+         , ConfiguredPackage(..) )+import Distribution.Client.Dependency.Types+         ( PackageName, DependencyResolver, PackageVersionPreference(..)+         , Progress(..), foldProgress )++import qualified Distribution.Simple.PackageIndex as PackageIndex+import Distribution.Simple.PackageIndex (PackageIndex)+import Distribution.InstalledPackageInfo+         ( InstalledPackageInfo )+import Distribution.Package+         ( PackageIdentifier, Package(packageId), packageVersion, packageName+         , Dependency(Dependency), thisPackageVersion, notThisPackageVersion+         , PackageFixedDeps(depends) )+import Distribution.PackageDescription+         ( PackageDescription(buildDepends) )+import Distribution.PackageDescription.Configuration+         ( finalizePackageDescription, flattenPackageDescription )+import Distribution.Compiler+         ( CompilerId )+import Distribution.System+         ( OS, Arch )+import Distribution.Simple.Utils+         ( equating, comparing )+import Distribution.Text+         ( display )++import Data.List+         ( foldl', maximumBy, minimumBy, deleteBy, nub, sort )+import Data.Maybe+         ( fromJust, fromMaybe )+import Data.Monoid+         ( Monoid(mempty) )+import Control.Monad+         ( guard )+import qualified Data.Set as Set+import Data.Set (Set)+import qualified Data.Map as Map+import qualified Data.Graph as Graph+import qualified Data.Array as Array++-- ------------------------------------------------------------+-- * Search state types+-- ------------------------------------------------------------++type Constraints  = Constraints.Constraints+                      InstalledPackage UnconfiguredPackage ExclusionReason+type SelectedPackages = PackageIndex SelectedPackage++-- ------------------------------------------------------------+-- * The search tree type+-- ------------------------------------------------------------++data SearchSpace inherited pkg+   = ChoiceNode inherited [[(pkg, SearchSpace inherited pkg)]]+   | Failure Failure++-- ------------------------------------------------------------+-- * Traverse a search tree+-- ------------------------------------------------------------++explore :: (PackageName -> PackageVersionPreference)+        -> SearchSpace a SelectablePackage+        -> Progress Log Failure a++explore _    (Failure failure)      = Fail failure+explore _explore    (ChoiceNode result []) = Done result+explore pref (ChoiceNode _ choices) =+  case [ choice | [choice] <- choices ] of+    ((pkg, node'):_) -> Step (Select pkg [])    (explore pref node')+    []               -> seq pkgs' -- avoid retaining defaultChoice+                      $ Step (Select pkg pkgs') (explore pref node')+      where+        choice       = minimumBy (comparing topSortNumber) choices+        pkgname      = packageName . fst . head $ choice+        (pkg, node') = maximumBy (bestByPref pkgname) choice+        pkgs' = deleteBy (equating packageId) pkg (map fst choice)++  where+    topSortNumber choice = case fst (head choice) of+      InstalledOnly           (InstalledPackage    _ i _) -> i+      AvailableOnly           (UnconfiguredPackage _ i _) -> i+      InstalledAndAvailable _ (UnconfiguredPackage _ i _) -> i++    bestByPref pkgname = case pref pkgname of+      PreferLatest    -> comparing (\(p,_) ->                 packageId p)+      PreferInstalled -> comparing (\(p,_) -> (isInstalled p, packageId p))+      where isInstalled (AvailableOnly _) = False+            isInstalled _                 = True++-- ------------------------------------------------------------+-- * Generate a search tree+-- ------------------------------------------------------------++type ConfigurePackage = PackageIndex SelectablePackage+                     -> SelectablePackage+                     -> Either [Dependency] SelectedPackage++searchSpace :: ConfigurePackage+            -> Constraints+            -> SelectedPackages+            -> Set PackageName+            -> SearchSpace (SelectedPackages, Constraints) SelectablePackage+searchSpace configure constraints selected next =+  ChoiceNode (selected, constraints)+    [ [ (pkg, select name pkg)+      | pkg <- PackageIndex.lookupPackageName available name ]+    | name <- Set.elems next ]+  where+    available = Constraints.choices constraints++    select name pkg = case configure available pkg of+      Left missing -> Failure $ ConfigureFailed pkg+                        [ (dep, Constraints.conflicting constraints dep)+                        | dep <- missing ]+      Right pkg' ->+        let selected' = PackageIndex.insert pkg' selected+            newPkgs   = [ name'+                        | dep <- packageConstraints pkg'+                        , let (Dependency name' _) = untagDependency dep+                        , null (PackageIndex.lookupPackageName selected' name') ]+            newDeps   = packageConstraints pkg'+            next'     = Set.delete name+                      $ foldl' (flip Set.insert) next newPkgs+         in case constrainDeps pkg' newDeps constraints of+              Left failure       -> Failure failure+              Right constraints' -> searchSpace configure+                                      constraints' selected' next'++packageConstraints :: SelectedPackage -> [TaggedDependency]+packageConstraints = either installedConstraints availableConstraints+                   . preferAvailable+  where+    preferAvailable (InstalledOnly           pkg) = Left pkg+    preferAvailable (AvailableOnly           pkg) = Right pkg+    preferAvailable (InstalledAndAvailable _ pkg) = Right pkg+    installedConstraints (InstalledPackage      _ _ deps) =+      [ TaggedDependency InstalledConstraint (thisPackageVersion dep)+      | dep <- deps ]+    availableConstraints (SemiConfiguredPackage _ _ deps) =+      [ TaggedDependency NoInstalledConstraint dep | dep <- deps ]++constrainDeps :: SelectedPackage -> [TaggedDependency] -> Constraints+              -> Either Failure Constraints+constrainDeps pkg []         cs =+  case addPackageSelectConstraint (packageId pkg) cs of+    Satisfiable cs' -> Right cs'+    _               -> impossible+constrainDeps pkg (dep:deps) cs =+  case addPackageDependencyConstraint (packageId pkg) dep cs of+    Satisfiable cs' -> constrainDeps pkg deps cs'+    Unsatisfiable   -> impossible+    ConflictsWith conflicts ->+      Left (DependencyConflict pkg dep conflicts)++-- ------------------------------------------------------------+-- * The main algorithm+-- ------------------------------------------------------------++search :: ConfigurePackage+       -> (PackageName -> PackageVersionPreference)+       -> Constraints+       -> Set PackageName+       -> Progress Log Failure (SelectedPackages, Constraints)+search configure pref constraints =+  explore pref . searchSpace configure constraints mempty++-- ------------------------------------------------------------+-- * The top level resolver+-- ------------------------------------------------------------++-- | The main exported resolver, with string logging and failure types to fit+-- the standard 'DependencyResolver' interface.+--+topDownResolver :: DependencyResolver+topDownResolver = ((((((mapMessages .).).).).).) . topDownResolver'+  where+    mapMessages :: Progress Log Failure a -> Progress String String a+    mapMessages = foldProgress (Step . showLog) (Fail . showFailure) Done++-- | The native resolver with detailed structured logging and failure types.+--+topDownResolver' :: OS -> Arch -> CompilerId+                 -> PackageIndex InstalledPackageInfo+                 -> PackageIndex AvailablePackage+                 -> (PackageName -> PackageVersionPreference)+                 -> [UnresolvedDependency]+                 -> Progress Log Failure [PlanPackage]+topDownResolver' os arch comp installed available pref deps =+      fmap (uncurry finalise)+    . (\cs -> search configure pref cs initialPkgNames)+  =<< constrainTopLevelDeps deps constraints++  where+    configure   = configurePackage os arch comp+    constraints = Constraints.empty+                    (annotateInstalledPackages      topSortNumber installed')+                    (annotateAvailablePackages deps topSortNumber available')+    (installed', available') = selectNeededSubset installed available+                                                  initialPkgNames+    topSortNumber = topologicalSortNumbering installed' available'++    initialDeps     = [ dep  | UnresolvedDependency dep _ <- deps ]+    initialPkgNames = Set.fromList [ name | Dependency name _ <- initialDeps ]++    finalise selected = PackageIndex.allPackages+                      . improvePlan installed'+                      . PackageIndex.fromList+                      . finaliseSelectedPackages selected++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)++configurePackage :: OS -> Arch -> CompilerId -> ConfigurePackage+configurePackage os arch comp available spkg = case spkg of+  InstalledOnly         ipkg      -> Right (InstalledOnly ipkg)+  AvailableOnly              apkg -> fmap AvailableOnly (configure apkg)+  InstalledAndAvailable ipkg apkg -> fmap (InstalledAndAvailable ipkg)+                                          (configure apkg)+  where+  configure (UnconfiguredPackage apkg@(AvailablePackage _ p _) _ flags) =+    case finalizePackageDescription flags (Just available) os arch comp [] p of+      Left missing        -> Left missing+      Right (pkg, flags') -> Right $+        SemiConfiguredPackage apkg flags' (buildDepends pkg)++-- | Annotate each installed packages with its set of transative dependencies+-- and its topological sort number.+--+annotateInstalledPackages :: (PackageName -> TopologicalSortNumber)+                          -> PackageIndex InstalledPackageInfo+                          -> PackageIndex InstalledPackage+annotateInstalledPackages dfsNumber installed = PackageIndex.fromList+  [ InstalledPackage pkg (dfsNumber (packageName pkg)) (transitiveDepends pkg)+  | pkg <- PackageIndex.allPackages installed ]+  where+    transitiveDepends :: InstalledPackageInfo -> [PackageIdentifier]+    transitiveDepends = map toPkgid . tail . Graph.reachable graph+                      . fromJust . toVertex . packageId+    (graph, toPkgid, toVertex) = PackageIndex.dependencyGraph installed+++-- | Annotate each available packages with its topological sort number and any+-- user-supplied partial flag assignment.+--+annotateAvailablePackages :: [UnresolvedDependency]+                          -> (PackageName -> TopologicalSortNumber)+                          -> PackageIndex AvailablePackage+                          -> PackageIndex UnconfiguredPackage+annotateAvailablePackages deps dfsNumber available = PackageIndex.fromList+  [ UnconfiguredPackage pkg (dfsNumber name) (flagsFor name)+  | pkg <- PackageIndex.allPackages available+  , let name = packageName pkg ]+  where+    flagsFor = fromMaybe [] . flip Map.lookup flagsMap+    flagsMap = Map.fromList+      [ (name, flags)+      | UnresolvedDependency (Dependency name _) flags <- deps ]++-- | 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+-- to make decisions about packages higer in the dep graph first since they+-- place constraints on packages lower in the dep graph.+--+-- To pick them in that order we annotate each package with its topological+-- sort number. So if package A depends on package B then package A will have+-- a lower topological sort number than B and we'll make a choice about which+-- version of A to pick before we make a choice about B (unless there is only+-- one possible choice for B in which case we pick that immediately).+--+-- To construct these topological sort numbers we combine and flatten the+-- installed and available package sets. We consider only dependencies between+-- named packages, not including versions and for not-yet-configured packages+-- we look at all the possible dependencies, not just those under any single+-- flag assignment. This means we can actually get impossible combinations of+-- edges and even cycles, but that doesn't really matter here, it's only a+-- heuristic.+--+topologicalSortNumbering :: PackageIndex InstalledPackageInfo+                         -> PackageIndex AvailablePackage+                         -> (PackageName -> TopologicalSortNumber)+topologicalSortNumbering installed available =+    \pkgname -> let Just vertex = toVertex pkgname+                 in topologicalSortNumbers Array.! vertex+  where+    topologicalSortNumbers = Array.array (Array.bounds graph)+                                         (zip (Graph.topSort graph) [0..])+    (graph, _, toVertex)   = Graph.graphFromEdges $+         [ ((), packageName pkg, nub deps)+         | pkgs@(pkg:_) <- PackageIndex.allPackagesByName installed+         , let deps = [ packageName dep+                      | pkg' <- pkgs+                      , dep  <- depends pkg' ] ]+      ++ [ ((), packageName pkg, nub deps)+         | pkgs@(pkg:_) <- PackageIndex.allPackagesByName available+         , let deps = [ depName+                      | AvailablePackage _ pkg' _ <- pkgs+                      , Dependency depName _ <-+                          buildDepends (flattenPackageDescription pkg') ] ]++-- | We don't need the entire index (which is rather large and costly if we+-- force it by examining the whole thing). So trace out the maximul subset of+-- each index that we could possibly ever need. Do this by flattening packages+-- and looking at the names of all possible dependencies.+--+selectNeededSubset :: PackageIndex InstalledPackageInfo+                   -> PackageIndex AvailablePackage+                   -> Set PackageName+                   -> (PackageIndex InstalledPackageInfo+                      ,PackageIndex AvailablePackage)+selectNeededSubset installed available = select mempty mempty+  where+    select :: PackageIndex InstalledPackageInfo+           -> PackageIndex AvailablePackage+           -> Set PackageName+           -> (PackageIndex InstalledPackageInfo+              ,PackageIndex AvailablePackage)+    select installed' available' remaining+      | Set.null remaining = (installed', available')+      | otherwise = select installed'' available'' remaining''+      where+        (next, remaining') = Set.deleteFindMin remaining+        moreInstalled = PackageIndex.lookupPackageName installed next+        moreAvailable = PackageIndex.lookupPackageName available next+        moreRemaining = nub+                      $ [ packageName dep+                        | pkg <- moreInstalled+                        , dep <- depends pkg ]+                     ++ [ name+                        | AvailablePackage _ pkg _ <- moreAvailable+                        , Dependency name _ <-+                            buildDepends (flattenPackageDescription pkg) ]+        installed''   = foldr PackageIndex.insert installed' moreInstalled+        available''   = foldr PackageIndex.insert available' moreAvailable+        remaining''   = foldr          Set.insert remaining' moreRemaining++-- ------------------------------------------------------------+-- * Post processing the solution+-- ------------------------------------------------------------++finaliseSelectedPackages :: SelectedPackages+                         -> Constraints+                         -> [PlanPackage]+finaliseSelectedPackages selected constraints =+  map finaliseSelected (PackageIndex.allPackages selected)+  where+    remainingChoices = Constraints.choices constraints+    finaliseSelected (InstalledOnly         ipkg     ) = finaliseInstalled ipkg+    finaliseSelected (AvailableOnly              apkg) = finaliseAvailable apkg+    finaliseSelected (InstalledAndAvailable ipkg apkg) =+      case PackageIndex.lookupPackageId remainingChoices (packageId ipkg) of+        Nothing                          -> impossible --picked package not in constraints+        Just (AvailableOnly _)           -> impossible --to constrain to avail only+        Just (InstalledOnly _)           -> finaliseInstalled ipkg+        Just (InstalledAndAvailable _ _) -> finaliseAvailable apkg++    finaliseInstalled (InstalledPackage pkg _ _) = InstallPlan.PreExisting pkg+    finaliseAvailable (SemiConfiguredPackage pkg flags deps) =+      InstallPlan.Configured (ConfiguredPackage pkg flags deps')+      where deps' = [ packageId pkg'+                    | dep <- deps+                    , let pkg' = case PackageIndex.lookupDependency selected dep of+                                   [pkg''] -> pkg''+                                   _ -> impossible ]++-- | Improve an existing installation plan by, where possible, swapping+-- packages we plan to install with ones that are already installed.+--+improvePlan :: PackageIndex InstalledPackageInfo+            -> PackageIndex PlanPackage+            -> PackageIndex PlanPackage+improvePlan installed selected = foldl' improve selected+                               $ reverseTopologicalOrder selected+  where+    improve selected' = maybe selected' (flip PackageIndex.insert selected')+                      . improvePkg selected'++    -- 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+      ipkg            <- PackageIndex.lookupPackageId installed pkgid+      guard $ sort (depends pkg) == nub (sort (depends ipkg))+      guard $ all (isInstalled selected') (depends pkg)+      return (PreExisting ipkg)++    isInstalled selected' pkgid =+      case PackageIndex.lookupPackageId selected' pkgid of+        Just (PreExisting _) -> True+        _                    -> False++    reverseTopologicalOrder :: PackageFixedDeps pkg => PackageIndex pkg+                            -> [PackageIdentifier]+    reverseTopologicalOrder index = map toPkgId+                                  . Graph.topSort+                                  . Graph.transposeG+                                  $ graph+      where (graph, toPkgId, _) = PackageIndex.dependencyGraph index++-- ------------------------------------------------------------+-- * Adding and recording constraints+-- ------------------------------------------------------------++addPackageSelectConstraint :: PackageIdentifier -> Constraints+                           -> Satisfiable Constraints ExclusionReason+addPackageSelectConstraint pkgid constraints =+  Constraints.constrain dep reason constraints+  where+    dep    = TaggedDependency NoInstalledConstraint (thisPackageVersion pkgid)+    reason = SelectedOther pkgid++addPackageExcludeConstraint :: PackageIdentifier -> Constraints+                     -> Satisfiable Constraints ExclusionReason+addPackageExcludeConstraint pkgid constraints =+  Constraints.constrain dep reason constraints+  where+    dep    = TaggedDependency NoInstalledConstraint+               (notThisPackageVersion pkgid)+    reason = ExcludedByConfigureFail++addPackageDependencyConstraint :: PackageIdentifier -> TaggedDependency -> Constraints+                               -> Satisfiable Constraints ExclusionReason+addPackageDependencyConstraint pkgid dep constraints =+  Constraints.constrain dep reason constraints+  where+    reason = ExcludedByPackageDependency pkgid dep++addTopLevelDependencyConstraint :: Dependency -> Constraints+                                -> Satisfiable Constraints ExclusionReason+addTopLevelDependencyConstraint dep constraints =+  Constraints.constrain taggedDep reason constraints+  where+    taggedDep = TaggedDependency NoInstalledConstraint dep+    reason = ExcludedByTopLevelDependency dep++-- ------------------------------------------------------------+-- * Reasons for constraints+-- ------------------------------------------------------------++-- | For every constraint we record we also record the reason that constraint+-- is needed. So if we end up failing due to conflicting constraints then we+-- can give an explnanation as to what was conflicting and why.+--+data ExclusionReason =++     -- | We selected this other version of the package. That means we exclude+     -- all the other versions.+     SelectedOther PackageIdentifier++     -- | We excluded this version of the package because it failed to+     -- configure probably because of unsatisfiable deps.+   | ExcludedByConfigureFail++     -- | We excluded this version of the package because another package that+     -- we selected imposed a dependency which this package did not satisfy.+   | ExcludedByPackageDependency PackageIdentifier TaggedDependency++     -- | We excluded this version of the package because it did not satisfy+     -- a dependency given as an original top level input.+     --+   | ExcludedByTopLevelDependency Dependency++-- | Given an excluded package and the reason it was excluded, produce a human+-- readable explanation.+--+showExclusionReason :: PackageIdentifier -> ExclusionReason -> String+showExclusionReason pkgid (SelectedOther pkgid') =+  display pkgid ++ " was excluded because " +++  display pkgid' ++ " was selected instead"+showExclusionReason pkgid ExcludedByConfigureFail =+  display pkgid ++ " was excluded because it could not be configured"+showExclusionReason pkgid (ExcludedByPackageDependency pkgid' dep) =+  display pkgid ++ " was excluded because " +++  display pkgid' ++ " requires " ++ display (untagDependency dep)+showExclusionReason pkgid (ExcludedByTopLevelDependency dep) =+  display pkgid ++ " was excluded because of the top level dependency " +++  display dep+++-- ------------------------------------------------------------+-- * Logging progress and failures+-- ------------------------------------------------------------++data Log = Select SelectablePackage [SelectablePackage]+data Failure+   = ConfigureFailed+       SelectablePackage+       [(Dependency, [(PackageIdentifier, [ExclusionReason])])]+   | DependencyConflict+       SelectedPackage TaggedDependency+       [(PackageIdentifier, [ExclusionReason])]+   | TopLevelDependencyConflict+       Dependency+       [(PackageIdentifier, [ExclusionReason])]+   | TopLevelDependencyUnsatisfiable+       Dependency++showLog :: Log -> String+showLog (Select selected discarded) =+     "selecting " ++ displayPkg selected ++ " " ++ kind selected+  ++ case discarded of+       []  -> ""+       [d] -> " and discarding version " ++ display (packageVersion d)+       _   -> " and discarding versions "+           ++ listOf (display . packageVersion) discarded+  where+    kind (InstalledOnly _)           = "(installed)"+    kind (AvailableOnly _)           = "(hackage)"+    kind (InstalledAndAvailable _ _) = "(installed or hackage)"++showFailure :: Failure -> String+showFailure (ConfigureFailed pkg missingDeps) =+     "cannot configure " ++ displayPkg pkg ++ ". It requires "+  ++ listOf (display . fst) missingDeps+  ++ '\n' : unlines (map (uncurry whyNot) missingDeps)++  where+    whyNot (Dependency name ver) [] =+         "There is no available version of " ++ name+      ++ " that satisfies " ++ display ver++    whyNot dep conflicts =+         "For the dependency on " ++ display dep+      ++ " there are these packages: " ++ listOf display pkgs+      ++ ". However none of them are available.\n"+      ++ unlines [ showExclusionReason (packageId pkg') reason+                 | (pkg', reasons) <- conflicts, reason <- reasons ]++      where pkgs = map fst conflicts++showFailure (DependencyConflict pkg (TaggedDependency _ dep) conflicts) =+     "dependencies conflict: "+  ++ displayPkg pkg ++ " requires " ++ display dep ++ " however\n"+  ++ unlines [ showExclusionReason (packageId pkg') reason+             | (pkg', reasons) <- conflicts, reason <- reasons ]++showFailure (TopLevelDependencyConflict dep conflicts) =+     "dependencies conflict: "+  ++ "top level dependency " ++ display dep ++ " however\n"+  ++ unlines [ showExclusionReason (packageId pkg') reason+             | (pkg', reasons) <- conflicts, reason <- reasons ]++showFailure (TopLevelDependencyUnsatisfiable (Dependency name ver)) =+     "There is no available version of " ++ name+      ++ " that satisfies " ++ display ver++-- ------------------------------------------------------------+-- * Utils+-- ------------------------------------------------------------++impossible :: a+impossible = internalError "impossible"++internalError :: String -> a+internalError msg = error $ "internal error: " ++ msg++displayPkg :: Package pkg => pkg -> String+displayPkg = display . packageId++listOf :: (a -> String) -> [a] -> String+listOf _    []   = []+listOf disp [x0] = disp x0+listOf disp (x0:x1:xs) = disp x0 ++ go x1 xs+  where go x []       = " and " ++ disp x+        go x (x':xs') = ", " ++ disp x ++ go x' xs'
+ Distribution/Client/Dependency/TopDown/Constraints.hs view
@@ -0,0 +1,244 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Dependency.TopDown.Constraints+-- Copyright   :  (c) Duncan Coutts 2008+-- License     :  BSD-like+--+-- Maintainer  :  duncan@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- A set of satisfiable dependencies (package version constraints).+-----------------------------------------------------------------------------+module Distribution.Client.Dependency.TopDown.Constraints (+  Constraints,+  empty,+  choices,+  +  constrain,+  Satisfiable(..),+  conflicting,+  ) where++import Distribution.Client.Dependency.TopDown.Types+import qualified Distribution.Simple.PackageIndex as PackageIndex+import Distribution.Simple.PackageIndex (PackageIndex)+import Distribution.Package+         ( PackageIdentifier, Package(packageId), packageVersion, packageName+         , Dependency(Dependency) )+import Distribution.Version+         ( withinRange )+import Distribution.Simple.Utils+         ( comparing )+import Distribution.Client.Utils+         ( mergeBy, MergeResult(..) )++import Data.List+         ( foldl', sortBy )+import Data.Monoid+         ( Monoid(mempty) )+import Control.Exception+         ( assert )++-- | A set of constraints on package versions. For each package name we record+-- what other packages depends on it and what constraints they impose on the+-- version of the package.+--+data (Package installed, Package available)+  => Constraints installed available reason+   = Constraints++       -- Remaining available choices+       (PackageIndex (InstalledOrAvailable installed available))+       +       -- Choices that we have excluded for some reason+       -- usually by applying constraints+       (PackageIndex (ExcludedPackage PackageIdentifier reason))++data ExcludedPackage pkg reason+   = ExcludedPackage pkg [reason] -- reasons for excluding just the available+                         [reason] -- reasons for excluding installed and avail++instance Package pkg => Package (ExcludedPackage pkg reason) where+  packageId (ExcludedPackage p _ _) = packageId p++-- | The intersection between the two indexes is empty+invariant :: (Package installed, Package available)+          => Constraints installed available a -> Bool+invariant (Constraints available excluded) =+  all (uncurry ok) [ (a, e) | InBoth a e <- merged ]+  where+    merged = mergeBy (\a b -> packageId a `compare` packageId b)+                     (PackageIndex.allPackages available)+                     (PackageIndex.allPackages excluded)+    ok (InstalledOnly _) (ExcludedPackage _ _ []) = True+    ok _                 _                        = 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') =+     invariant constraints && invariant constraints'+  && null availableGained  && null excludedLost+  && map packageId availableLost == map packageId excludedGained++  where+    availableLost   = foldr lost [] availableChange where+      lost (OnlyInLeft  pkg)          rest = pkg : rest+      lost (InBoth (InstalledAndAvailable _ pkg)+                   (InstalledOnly _)) rest = AvailableOnly pkg : rest+      lost _                          rest = rest+    availableGained = [ pkg | OnlyInRight pkg <- availableChange ]+    excludedLost    = [ pkg | OnlyInLeft  pkg <- excludedChange  ]+    excludedGained  = [ pkg | OnlyInRight pkg <- excludedChange  ]+    availableChange = mergeBy (\a b -> packageId a `compare` packageId b)+                              (allPackagesInOrder available)+                              (allPackagesInOrder available')+    excludedChange  = mergeBy (\a b -> packageId a `compare` packageId b)+                              (allPackagesInOrder excluded)+                              (allPackagesInOrder excluded')++--FIXME: PackageIndex.allPackages returns in sorted order case-insensitively+-- but that's no good for our merge which uses Ord+allPackagesInOrder :: Package pkg => PackageIndex pkg -> [pkg]+allPackagesInOrder index = +    concatMap snd+  . sortBy (comparing fst)+  $ [ (packageName pkg, grp)+    | grp@(pkg:_) <- PackageIndex.allPackagesByName index ]++-- | We construct 'Constraints' with an initial 'PackageIndex' of all the+-- packages available.+--+empty :: (Package installed, Package available)+      => PackageIndex installed+      -> PackageIndex available+      -> Constraints installed available reason+empty installed available = Constraints pkgs mempty+  where+    pkgs = PackageIndex.fromList+         . map toInstalledOrAvailable+         $ mergeBy (\a b -> packageId a `compare` packageId b)+                   (allPackagesInOrder installed)+                   (allPackagesInOrder available) +    toInstalledOrAvailable (OnlyInLeft  i  ) = InstalledOnly         i+    toInstalledOrAvailable (OnlyInRight   a) = AvailableOnly           a+    toInstalledOrAvailable (InBoth      i a) = InstalledAndAvailable i a ++-- | The package choices that are still available.+--+choices :: (Package installed, Package available)+        => Constraints installed available reason+        -> PackageIndex (InstalledOrAvailable installed available)+choices (Constraints available _) = available++data Satisfiable a reason+       = Satisfiable a+       | Unsatisfiable+       | ConflictsWith [(PackageIdentifier, [reason])]++constrain :: (Package installed, Package available)+          => TaggedDependency+          -> reason+          -> Constraints installed available reason+          -> Satisfiable (Constraints installed available reason) reason+constrain (TaggedDependency installedConstraint (Dependency name versionRange))+          reason constraints@(Constraints available excluded)++  | not anyRemaining+  = if null conflicts then Unsatisfiable+                      else ConflictsWith conflicts++  | otherwise +  = let constraints' = Constraints available' excluded'+     in assert (constraints `transitionsTo` constraints') $+        Satisfiable constraints'++  where+  -- This tells us if any packages would remain at all for this package name if+  -- we applied this constraint. This amounts to checking if any package+  -- satisfies the given constraint, including version range and installation+  -- status.+  --+  anyRemaining = any satisfiesConstraint availableChoices++  conflicts = [ (packageId pkg, reasonsAvail ++ reasonsAll)+              | ExcludedPackage pkg reasonsAvail reasonsAll <- excludedChoices+              , satisfiesVersionConstraint pkg ]++  -- Applying this constraint may involve deleting some choices for this+  -- package name, or restricting which install states are available.+  available' = updateAvailable available+  updateAvailable = flip (foldl' (flip update)) availableChoices where+    update pkg | not (satisfiesVersionConstraint pkg)+               = PackageIndex.deletePackageId (packageId pkg)+    update _   | installedConstraint == NoInstalledConstraint+               = id+    update pkg = case pkg of+      InstalledOnly         _   -> id+      AvailableOnly           _ -> error "impossible" -- PackageIndex.deletePackageId (packageId pkg)+      InstalledAndAvailable i _ -> PackageIndex.insert (InstalledOnly i)++  -- Applying the constraint means adding exclusions for the packages that+  -- we're just freshly excluding, ie the ones we're removing from available.+  excluded' = addNewExcluded . addOldExcluded $ excluded+  addNewExcluded index = foldl' (flip exclude) index availableChoices where+    exclude pkg+      | not (satisfiesVersionConstraint pkg)+      = PackageIndex.insert $ ExcludedPackage pkgid [] [reason]+      | installedConstraint == NoInstalledConstraint+      = id+      | otherwise = case pkg of+      InstalledOnly         _   -> id+      AvailableOnly           _ -> PackageIndex.insert+                                     (ExcludedPackage pkgid [reason] [])+      InstalledAndAvailable _ _ ->+        case PackageIndex.lookupPackageId excluded pkgid of+          Just (ExcludedPackage _ avail both) ->+            PackageIndex.insert (ExcludedPackage pkgid (reason:avail) both)+          Nothing ->+            PackageIndex.insert (ExcludedPackage pkgid [reason] [])+      where pkgid = packageId pkg++  -- Additionally we have to add extra exclusions for any already-excluded+  -- packages that happen to be covered by the (inverse of the) constraint.+  addOldExcluded = flip (foldl' (flip exclude)) excludedChoices where+    exclude (ExcludedPackage pkgid avail both)+      -- if it doesn't satisfy the version constraint then we exclude the+      -- package as a whole, the available or the installed instances or both.+      | not (satisfiesVersionConstraint pkgid)+      = PackageIndex.insert (ExcludedPackage pkgid avail (reason:both))+      -- if on the other hand it does satisfy the constraint and we were also+      -- constraining to just the installed version then we exclude just the+      -- available instance.+      | installedConstraint == InstalledConstraint+      = PackageIndex.insert (ExcludedPackage pkgid (reason:avail) both)+      | otherwise = id++  -- util definitions+  availableChoices = PackageIndex.lookupPackageName available name+  excludedChoices  = PackageIndex.lookupPackageName excluded  name++  satisfiesConstraint pkg = satisfiesVersionConstraint pkg+                         && satisfiesInstallStateConstraint pkg++  satisfiesVersionConstraint pkg =+    packageVersion pkg `withinRange` versionRange++  satisfiesInstallStateConstraint = case installedConstraint of+    NoInstalledConstraint -> \_   -> True+    InstalledConstraint   -> \pkg -> case pkg of+      AvailableOnly _             -> False+      _                           -> True++conflicting :: (Package installed, Package available)+            => Constraints installed available reason+            -> Dependency+            -> [(PackageIdentifier, [reason])]+conflicting (Constraints _ excluded) dep =+  [ (pkgid, reasonsAvail ++ reasonsAll) --TODO+  | ExcludedPackage pkgid reasonsAvail reasonsAll <-+      PackageIndex.lookupDependency excluded dep ]
+ Distribution/Client/Dependency/TopDown/Types.hs view
@@ -0,0 +1,90 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Dependency.TopDown.Types+-- Copyright   :  (c) Duncan Coutts 2008+-- License     :  BSD-like+--+-- Maintainer  :  cabal-devel@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- Types for the top-down dependency resolver.+-----------------------------------------------------------------------------+module Distribution.Client.Dependency.TopDown.Types where++import Distribution.Client.Types+         ( AvailablePackage(..) )++import Distribution.InstalledPackageInfo (InstalledPackageInfo)+import Distribution.Package+         ( PackageIdentifier, Dependency, Package(packageId) )+import Distribution.PackageDescription+         ( FlagAssignment )++-- ------------------------------------------------------------+-- * The various kinds of packages+-- ------------------------------------------------------------++type SelectablePackage+   = InstalledOrAvailable InstalledPackage UnconfiguredPackage++type SelectedPackage+   = InstalledOrAvailable InstalledPackage SemiConfiguredPackage++data InstalledOrAvailable installed available+   = InstalledOnly         installed+   | AvailableOnly                   available+   | InstalledAndAvailable installed available++type TopologicalSortNumber = Int++data InstalledPackage+   = InstalledPackage+       InstalledPackageInfo+       !TopologicalSortNumber+       [PackageIdentifier]++data UnconfiguredPackage+   = UnconfiguredPackage+       AvailablePackage+       !TopologicalSortNumber+       FlagAssignment++data SemiConfiguredPackage+   = SemiConfiguredPackage+       AvailablePackage  -- package info+       FlagAssignment    -- total flag assignment for the package+       [Dependency]      -- dependencies we end up with when we apply+                         -- the flag assignment++instance Package InstalledPackage where+  packageId (InstalledPackage p _ _) = packageId p++instance Package UnconfiguredPackage where+  packageId (UnconfiguredPackage p _ _) = packageId p++instance Package SemiConfiguredPackage where+  packageId (SemiConfiguredPackage p _ _) = packageId p++instance (Package installed, Package available)+      => Package (InstalledOrAvailable installed available) where+  packageId (InstalledOnly         p  ) = packageId p+  packageId (AvailableOnly         p  ) = packageId p+  packageId (InstalledAndAvailable p _) = packageId p++-- ------------------------------------------------------------+-- * Tagged Dependency type+-- ------------------------------------------------------------++-- | Installed packages can only depend on other installed packages while+-- packages that are not yet installed but which we plan to install can depend+-- on installed or other not-yet-installed packages.+--+-- This makes life more complex as we have to remember these constraints.+--+data TaggedDependency = TaggedDependency InstalledConstraint Dependency+data InstalledConstraint = InstalledConstraint | NoInstalledConstraint+  deriving Eq++untagDependency :: TaggedDependency -> Dependency+untagDependency (TaggedDependency _ dep) = dep
+ Distribution/Client/Dependency/Types.hs view
@@ -0,0 +1,90 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Dependency.Types+-- Copyright   :  (c) Duncan Coutts 2008+-- License     :  BSD-like+--+-- Maintainer  :  cabal-devel@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- Common types for dependency resolution.+-----------------------------------------------------------------------------+module Distribution.Client.Dependency.Types (+    PackageName,+    DependencyResolver,+    PackageVersionPreference(..),+    Progress(..),+    foldProgress,+  ) where++import Distribution.Client.Types+         ( UnresolvedDependency(..), AvailablePackage(..) )+import qualified Distribution.Client.InstallPlan as InstallPlan++import Distribution.InstalledPackageInfo+         ( InstalledPackageInfo )+import Distribution.Simple.PackageIndex+         ( PackageIndex )+import Distribution.Compiler+         ( CompilerId )+import Distribution.System+         ( OS, Arch )++import Prelude hiding (fail)++type PackageName  = String++-- | A dependency resolver is a function that works out an installation plan+-- given the set of installed and available packages and a set of deps to+-- solve for.+--+-- The reason for this interface is because there are dozens of approaches to+-- solving the package dependency problem and we want to make it easy to swap+-- in alternatives.+--+type DependencyResolver = OS+                       -> Arch+                       -> CompilerId+                       -> PackageIndex InstalledPackageInfo+                       -> PackageIndex AvailablePackage+                       -> (PackageName -> PackageVersionPreference)+                       -> [UnresolvedDependency]+                       -> Progress String String [InstallPlan.PlanPackage]++-- | A per-package preference on the version. It is a soft constraint that the+-- 'DependencyResolver' should try to respect where possible.+--+-- It is not specified if preferences on some packages are more important than+-- others.+--+data PackageVersionPreference = 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+-- retult which may be used to indicate progress and\/or logging messages.+--+data Progress step fail done = Step step (Progress step fail done)+                             | Fail fail+                             | Done done++-- | Consume a 'Progres' calculation. Much like 'foldr' for lists but with+-- two base cases, one for a final result and one for failure.+--+-- Eg to convert into a simple 'Either' result use:+--+-- > foldProgress (flip const) Left Right+--+foldProgress :: (step -> a -> a) -> (fail -> a) -> (done -> a)+             -> Progress step fail done -> a+foldProgress step fail done = fold+  where fold (Step s p) = step s (fold p)+        fold (Fail f)   = fail f+        fold (Done r)   = done r++instance Functor (Progress step fail) where+  fmap f = foldProgress Step Fail (Done . f)++instance Monad (Progress step fail) where+  return a = Done a+  p >>= f  = foldProgress Step Fail f p
+ Distribution/Client/Fetch.hs view
@@ -0,0 +1,214 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Fetch+-- Copyright   :  (c) David Himmelstrup 2005+-- License     :  BSD-like+--+-- Maintainer  :  lemmih@gmail.com+-- Stability   :  provisional+-- Portability :  portable+--+--+-----------------------------------------------------------------------------+module Distribution.Client.Fetch (++    -- * Commands+    fetch,++    -- * Utilities+    fetchPackage,+    isFetched,+    downloadIndex,+  ) where++import Distribution.Client.Types+         ( UnresolvedDependency (..), AvailablePackage(..)+         , AvailablePackageSource(..)+         , Repo(..), RemoteRepo(..), LocalRepo(..) )+import Distribution.Client.Dependency+         ( resolveDependenciesWithProgress, PackagesVersionPreference(..) )+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.Package+         ( PackageIdentifier(..), Dependency(..) )+import qualified Distribution.Simple.PackageIndex as PackageIndex+import Distribution.Simple.Compiler+         ( Compiler(compilerId), PackageDB )+import Distribution.Simple.Program+         ( ProgramConfiguration )+import Distribution.Simple.Configure+         ( getInstalledPackages )+import Distribution.Simple.Utils+         ( die, notice, info, debug, setupMessage+         , copyFileVerbose, writeFileAtomic )+import Distribution.System+         ( buildOS, buildArch )+import Distribution.Text+         ( display )+import Distribution.Verbosity+         ( Verbosity )++import Control.Monad+         ( when, filterM )+import System.Directory+         ( doesFileExist, createDirectoryIfMissing )+import System.FilePath+         ( (</>), (<.>) )+import qualified System.FilePath.Posix as FilePath.Posix+         ( combine, joinPath )+import Network.URI+         ( URI(uriPath, uriScheme) )+import Network.HTTP+         ( ConnError(..), Response(..) )+++downloadURI :: Verbosity+            -> FilePath -- ^ Where to put it+            -> URI      -- ^ What to download+            -> IO (Maybe ConnError)+downloadURI verbosity path uri | uriScheme uri == "file:" = do+  copyFileVerbose verbosity (uriPath uri) path+  return Nothing+downloadURI verbosity path uri = do+  eitherResult <- getHTTP verbosity uri+  case eitherResult of+    Left err -> return (Just err)+    Right rsp+      | rspCode rsp == (2,0,0)+     -> 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.+     --      remember the ETag so we can not re-download if nothing changed.+     >> return Nothing++      | otherwise+     -> return (Just (ErrorMisc ("Unsucessful HTTP code: " ++ show (rspCode rsp))))++-- Downloads a package to [config-dir/packages/package-id] and returns the path to the package.+downloadPackage :: Verbosity -> Repo -> PackageIdentifier -> IO String+downloadPackage _ repo@Repo{ repoKind = Right LocalRepo } pkgid =+  return (packageFile repo pkgid)++downloadPackage verbosity repo@Repo{ repoKind = Left remoteRepo } pkgid = do+  let uri  = packageURI remoteRepo pkgid+      dir  = packageDir       repo pkgid+      path = packageFile      repo pkgid+  debug verbosity $ "GET " ++ show uri+  createDirectoryIfMissing True dir+  status <- downloadURI verbosity path uri+  case status of+    Just err -> die $ "Failed to download '" ++ display pkgid+                   ++ "': " ++ show err+    Nothing  -> return path++-- Downloads an index file to [config-dir/packages/serv-id].+downloadIndex :: Verbosity -> RemoteRepo -> FilePath -> IO FilePath+downloadIndex verbosity repo cacheDir = do+  let uri = (remoteRepoURI repo) {+              uriPath = uriPath (remoteRepoURI repo)+	                  `FilePath.Posix.combine` "00-index.tar.gz"+            }+      path = cacheDir </> "00-index" <.> "tar.gz"+  createDirectoryIfMissing True cacheDir+  mbError <- downloadURI verbosity path uri+  case mbError of+    Just err -> die $ "Failed to download index '" ++ show err ++ "'"+    Nothing  -> return path++-- |Returns @True@ if the package has already been fetched.+isFetched :: AvailablePackage -> IO Bool+isFetched (AvailablePackage pkgid _ source) = case source of+  LocalUnpackedPackage    -> return True+  RepoTarballPackage repo -> doesFileExist (packageFile repo pkgid)++-- |Fetch a package if we don't have it already.+fetchPackage :: Verbosity -> Repo -> PackageIdentifier -> IO String+fetchPackage verbosity repo pkgid = do+  fetched <- doesFileExist (packageFile repo pkgid)+  if fetched+    then do notice verbosity $ "'" ++ display pkgid ++ "' is cached."+            return (packageFile repo pkgid)+    else do setupMessage verbosity "Downloading" pkgid+            downloadPackage verbosity repo pkgid++-- |Fetch a list of packages and their dependencies.+fetch :: Verbosity+      -> PackageDB+      -> [Repo]+      -> Compiler+      -> ProgramConfiguration+      -> [UnresolvedDependency]+      -> IO ()+fetch verbosity packageDB repos comp conf deps = do+  installed <- getInstalledPackages verbosity comp packageDB conf+  available <- getAvailablePackages verbosity repos+  deps' <- IndexUtils.disambiguateDependencies available deps++  let -- Hide the packages given on the command line so that the dep resolver+      -- will decide that they need fetching, even if they're already+      -- installed. Sicne we want to get the source packages of things we might+      -- have installed (but not have the sources for).+      installed' = fmap (hideGivenDeps deps') installed+      hideGivenDeps pkgs index =+        foldr PackageIndex.deletePackageName index+          [ name | UnresolvedDependency (Dependency name _) _ <- pkgs ]++  let  progress = resolveDependenciesWithProgress+                   buildOS buildArch (compilerId comp)+                   installed' available PreferLatestForSelected deps'+  notice verbosity "Resolving dependencies..."+  maybePlan <- foldProgress (\message rest -> info verbosity message >> rest)+                            (return . Left) (return . Right) progress+  case maybePlan of+    Left message -> die message+    Right pkgs   -> do+      ps <- filterM (fmap not . isFetched)+              [ pkg | (InstallPlan.Configured+                        (InstallPlan.ConfiguredPackage pkg _ _))+                          <- InstallPlan.toList pkgs ]+      when (null ps) $+        notice verbosity $ "No packages need to be fetched. "+                        ++ "All the requested packages are already cached."++      sequence_ +        [ fetchPackage verbosity repo pkgid+        | (AvailablePackage pkgid _ (RepoTarballPackage repo)) <- ps ]++-- |Generate the full path to the locally cached copy of+-- the tarball for a given @PackageIdentifer@.+packageFile :: Repo -> PackageIdentifier -> FilePath+packageFile repo pkgid = packageDir repo pkgid+                     </> display pkgid+                     <.> "tar.gz"++-- |Generate the full path to the directory where the local cached copy of+-- the tarball for a given @PackageIdentifer@ is stored.+packageDir :: Repo -> PackageIdentifier -> FilePath+packageDir repo pkgid = repoLocalDir repo+                    </> pkgName pkgid+                    </> display (pkgVersion pkgid)++-- | Generate the URI of the tarball for a given package.+packageURI :: RemoteRepo -> PackageIdentifier -> URI+packageURI repo pkgid | isOldHackageURI (remoteRepoURI repo) =+  (remoteRepoURI repo) {+    uriPath = FilePath.Posix.joinPath+      [uriPath (remoteRepoURI repo)+      ,pkgName pkgid+      ,display (pkgVersion pkgid)+      ,display pkgid <.> "tar.gz"]+  }+packageURI repo pkgid =+  (remoteRepoURI repo) {+    uriPath = FilePath.Posix.joinPath+      [uriPath (remoteRepoURI repo)+      ,"packages"+      ,display pkgid+      ,"tarball"]+  }
+ Distribution/Client/HttpUtils.hs view
@@ -0,0 +1,145 @@+{-# OPTIONS -cpp #-}+-----------------------------------------------------------------------------+-- | Separate module for HTTP actions, using a proxy server if one exists +-----------------------------------------------------------------------------+module Distribution.Client.HttpUtils (getHTTP, proxy, isOldHackageURI) where++import Network.HTTP+         ( Request (..), Response (..), RequestMethod (..)+         , Header(..), HeaderName(..) )+import Network.URI+         ( URI (..), URIAuth (..), parseAbsoluteURI )+import Network.Stream (Result)+import Network.Browser+         ( Proxy (..), Authority (..), browse+         , setOutHandler, setErrHandler, setProxy, request)+import Control.Monad+         ( mplus, join )+#ifdef WIN32+import System.Win32.Types+         ( DWORD, HKEY )+import System.Win32.Registry+         ( hKEY_CURRENT_USER, regOpenKey, regCloseKey+         , regQueryValue, regQueryValueEx )+import Control.Exception+         ( handle, bracket )+import Foreign+         ( toBool, Storable(peek, sizeOf), castPtr, alloca )+#else+import System.Environment (getEnvironment)+#endif++import qualified Paths_cabal_install (version)+import Distribution.Verbosity (Verbosity)+import Distribution.Simple.Utils (warn, debug)+import Distribution.Text+         ( display )+import qualified System.FilePath.Posix as FilePath.Posix+         ( splitDirectories )++-- FIXME: all this proxy stuff is far too complicated, especially parsing+-- the proxy strings. Network.Browser should have a way to pick up the+-- proxy settings hiding all this system-dependent stuff below.++-- try to read the system proxy settings on windows or unix+proxyString :: IO (Maybe String)+#ifdef WIN32+-- read proxy settings from the windows registry+proxyString = handle (\_ -> return Nothing) $+  bracket (regOpenKey hive path) regCloseKey $ \hkey -> do+    enable <- fmap toBool $ regQueryValueDWORD hkey "ProxyEnable"+    if enable+        then fmap Just $ regQueryValue hkey (Just "ProxyServer")+        else return Nothing+  where+    -- some sources say proxy settings should be at +    -- HKEY_LOCAL_MACHINE\SOFTWARE\Policies\Microsoft\Windows+    --                   \CurrentVersion\Internet Settings\ProxyServer+    -- but if the user sets them with IE connection panel they seem to+    -- end up in the following place:+    hive  = hKEY_CURRENT_USER+    path = "Software\\Microsoft\\Windows\\CurrentVersion\\Internet Settings"++    regQueryValueDWORD :: HKEY -> String -> IO DWORD+    regQueryValueDWORD hkey name = alloca $ \ptr -> do+      regQueryValueEx hkey name (castPtr ptr) (sizeOf (undefined :: DWORD))+      peek ptr+#else+-- read proxy settings by looking for an env var+proxyString = do+  env <- getEnvironment+  return (lookup "http_proxy" env `mplus` lookup "HTTP_PROXY" env)+#endif++-- |Get the local proxy settings  +proxy :: Verbosity -> IO Proxy+proxy verbosity = do+  mstr <- proxyString+  case mstr of+    Nothing   -> return NoProxy+    Just str  -> case parseHttpProxy str of+      Nothing -> do+        warn verbosity $ "invalid http proxy uri: " ++ show str+        warn verbosity $ "proxy uri must be http with a hostname"+        warn verbosity $ "ignoring http proxy, trying a direct connection"+        return NoProxy+      Just p  -> return p++-- | We need to be able to parse non-URIs like @\"wwwcache.example.com:80\"@+-- which lack the @\"http://\"@ URI scheme. The problem is that+-- @\"wwwcache.example.com:80\"@ is in fact a valid URI but with scheme+-- @\"wwwcache.example.com:\"@, no authority part and a path of @\"80\"@.+--+-- So our strategy is to try parsing as normal uri first and if it lacks the+-- 'uriAuthority' then we try parsing again with a @\"http://\"@ prefix.+--+parseHttpProxy :: String -> Maybe Proxy+parseHttpProxy str = join+                   . fmap uri2proxy+                   $ parseHttpURI str+             `mplus` parseHttpURI ("http://" ++ str)+  where+    parseHttpURI str' = case parseAbsoluteURI str' of+      Just uri@URI { uriAuthority = Just _ }+         -> Just uri+      _  -> Nothing++uri2proxy :: URI -> Maybe Proxy+uri2proxy uri@URI{ uriScheme = "http:"+                 , uriAuthority = Just (URIAuth auth' host port)+                 } = Just (Proxy (host ++ port) auth)+  where auth = if null auth'+                 then Nothing+                 else Just (AuthBasic "" usr pwd uri)+        (usr,pwd') = break (==':') auth'+        pwd        = case pwd' of+                       ':':cs -> cs+                       _      -> pwd'+uri2proxy _ = Nothing++mkRequest :: URI -> Request+mkRequest uri = Request{ rqURI     = uri+                       , rqMethod  = GET+                       , rqHeaders = [Header HdrUserAgent userAgent]+                       , rqBody    = "" }+  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 = do+                 p   <- proxy verbosity+                 let req = mkRequest uri+                 (_, resp) <- browse $ do+                                setErrHandler (warn verbosity . ("http error: "++))+                                setOutHandler (debug verbosity)+                                setProxy p+                                request req+                 return (Right resp)++-- Utility function for legacy support.+isOldHackageURI :: URI -> Bool+isOldHackageURI uri+    = case uriAuthority uri of+        Just (URIAuth {uriRegName = "hackage.haskell.org"}) ->+            FilePath.Posix.splitDirectories (uriPath uri) == ["/","packages","archive"]+        _ -> False
+ Distribution/Client/IndexUtils.hs view
@@ -0,0 +1,148 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.IndexUtils+-- Copyright   :  (c) Duncan Coutts 2008+-- License     :  BSD-like+--+-- Maintainer  :  duncan@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- Extra utils related to the package indexes.+-----------------------------------------------------------------------------+module Distribution.Client.IndexUtils (+  getAvailablePackages,+  readRepoIndex,+  disambiguatePackageName,+  disambiguateDependencies+  ) where++import qualified Distribution.Client.Tar as Tar+import Distribution.Client.Types+         ( UnresolvedDependency(..), AvailablePackage(..)+         , AvailablePackageSource(..), Repo(..), RemoteRepo(..) )++import Distribution.Package+         ( PackageIdentifier(..), Package(..), Dependency(Dependency) )+import Distribution.Simple.PackageIndex (PackageIndex)+import qualified Distribution.Simple.PackageIndex as PackageIndex+import Distribution.PackageDescription+         ( parsePackageDescription )+import Distribution.ParseUtils+         ( ParseResult(..) )+import Distribution.Text+         ( simpleParse )+import Distribution.Verbosity (Verbosity)+import Distribution.Simple.Utils (die, warn, info, intercalate, fromUTF8)++import Data.Maybe  (catMaybes)+import Data.Monoid (Monoid(..))+import Control.Exception (evaluate)+import qualified Data.ByteString.Lazy as BS+import qualified Data.ByteString.Lazy.Char8 as BS.Char8+import Data.ByteString.Lazy (ByteString)+import System.FilePath ((</>), takeExtension, splitDirectories, normalise)+import System.IO.Error (isDoesNotExistError)+++getAvailablePackages :: Verbosity -> [Repo]+                     -> IO (PackageIndex AvailablePackage)+getAvailablePackages verbosity repos = do+  info verbosity "Reading available packages..."+  pkgss <- mapM (readRepoIndex verbosity) repos+  evaluate (mconcat pkgss)++-- | Read a repository index from disk, from the local file specified by+-- the 'Repo'.+--+readRepoIndex :: Verbosity -> Repo -> IO (PackageIndex AvailablePackage)+readRepoIndex verbosity repo =+  handleNotFound $ do+    let indexFile = repoLocalDir repo </> "00-index.tar"+    pkgs <- either fail return . parseRepoIndex =<< BS.readFile indexFile+    evaluate (PackageIndex.fromList pkgs)++  where+    -- | Parse a repository index file from a 'ByteString'.+    --+    -- All the 'AvailablePackage's are marked as having come from the given 'Repo'.+    --+    parseRepoIndex :: ByteString -> Either String [AvailablePackage]+    parseRepoIndex = either Left (Right . catMaybes . map extractPkg)+                   . check [] . Tar.read++    check _  (Tar.Fail err)  = Left  err+    check ok Tar.Done        = Right ok+    check ok (Tar.Next e es) = check (e:ok) es++    extractPkg :: Tar.Entry -> Maybe AvailablePackage+    extractPkg entry+      | takeExtension fileName == ".cabal"+      = case splitDirectories (normalise fileName) of+          [pkgname,vers,_] -> case simpleParse vers of+            Just ver -> Just AvailablePackage {+                packageInfoId      = PackageIdentifier pkgname ver,+                packageDescription = descr,+                packageSource      = RepoTarballPackage repo+              }+            _ -> Nothing+            where+              parsed = parsePackageDescription . fromUTF8 . BS.Char8.unpack+                                               . Tar.fileContent $ entry+              descr  = case parsed of+                ParseOk _ d -> d+                _           -> error $ "Couldn't read cabal file "+                                    ++ show fileName+          _ -> Nothing+      | otherwise = Nothing+      where+        fileName = Tar.fileName entry++    handleNotFound action = catch action $ \e -> if isDoesNotExistError e+      then do+        case repoKind repo of+          Left  remoteRepo -> warn verbosity $+               "The package list for '" ++ remoteRepoName remoteRepo+            ++ "' does not exist. Run 'cabal update' to download it."+          Right _localRepo -> warn verbosity $+               "The package list for the local repo '" ++ repoLocalDir repo+            ++ "' is missing. The repo is invalid."+        return mempty+      else ioError e++-- | Disambiguate a set of packages using 'disambiguatePackage' and report any+-- ambiguities to the user.+--+disambiguateDependencies :: PackageIndex AvailablePackage+                         -> [UnresolvedDependency]+                         -> IO [UnresolvedDependency]+disambiguateDependencies index deps = do+  let names = [ (name, disambiguatePackageName index name)+              | UnresolvedDependency (Dependency name _) _ <- deps ]+   in case [ (name, matches) | (name, Right matches) <- names ] of+        []        -> return+          [ UnresolvedDependency (Dependency name vrange) flags+          | (UnresolvedDependency (Dependency _ vrange) flags,+             (_, Left name)) <- zip deps names ]+        ambigious -> die $ unlines+          [ if null matches+              then "There is no package named " ++ name+              else "The package name " ++ name ++ "is ambigious. "+                ++ "It could be: " ++ intercalate ", " matches+          | (name, matches) <- ambigious ]++-- | Given an index of known packages and a package name, figure out which one it+-- might be referring to. If there is an exact case-sensitive match then that's+-- ok. If it matches just one package case-insensitively then that's also ok.+-- The only problem is if it matches multiple packages case-insensitively, in+-- that case it is ambigious.+--+disambiguatePackageName :: PackageIndex AvailablePackage+                        -> String+                        -> Either String [String]+disambiguatePackageName index name =+    case PackageIndex.searchByName index name of+      PackageIndex.None              -> Right []+      PackageIndex.Unambiguous pkgs  -> Left (pkgName (packageId (head pkgs)))+      PackageIndex.Ambiguous   pkgss -> Right [ pkgName (packageId pkg)+                                           | (pkg:_) <- pkgss ]
+ Distribution/Client/Install.hs view
@@ -0,0 +1,554 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Install+-- Copyright   :  (c) David Himmelstrup 2005+-- License     :  BSD-like+--+-- Maintainer  :  lemmih@gmail.com+-- Stability   :  provisional+-- Portability :  portable+--+-- High level interface to package installation.+-----------------------------------------------------------------------------+module Distribution.Client.Install (+    install,+    upgrade,+  ) where++import Data.List+         ( unfoldr )+import Data.Maybe+         ( isJust )+import Control.Exception as Exception+         ( handle, Exception )+import Control.Monad+         ( when, unless, forM_ )+import System.Directory+         ( getTemporaryDirectory, doesFileExist, createDirectoryIfMissing )+import System.FilePath+         ( (</>), (<.>), takeDirectory )+import System.IO+         ( openFile, IOMode(AppendMode) )++import Distribution.Client.Dependency+         ( resolveDependenciesWithProgress, PackagesVersionPreference(..)+         , upgradableDependencies )+import Distribution.Client.Dependency.Types (Progress(..), foldProgress)+import Distribution.Client.Fetch (fetchPackage)+-- import qualified Distribution.Client.Info as Info+import Distribution.Client.IndexUtils as IndexUtils+         ( getAvailablePackages, disambiguateDependencies )+import qualified Distribution.Client.InstallPlan as InstallPlan+import Distribution.Client.InstallPlan (InstallPlan)+import Distribution.Client.Setup+         ( InstallFlags(..), configureCommand, filterConfigureFlags )+import Distribution.Client.Config+         ( defaultLogsDir, defaultCabalDir )+import Distribution.Client.Tar (extractTarGzFile)+import Distribution.Client.Types as Available+         ( UnresolvedDependency(..), AvailablePackage(..)+         , AvailablePackageSource(..), Repo(..), ConfiguredPackage(..)+         , BuildResult, BuildFailure(..), BuildSuccess(..)+         , DocsResult(..), TestsResult(..), RemoteRepo(..) )+import Distribution.Client.SetupWrapper+         ( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions )+import qualified Distribution.Client.BuildReports.Anonymous as BuildReports+import qualified Distribution.Client.BuildReports.Storage as BuildReports+         ( storeAnonymous, storeLocal, fromInstallPlan )+import qualified Distribution.Client.InstallSymlink as InstallSymlink+         ( symlinkBinaries )+import qualified Distribution.Client.Win32SelfUpgrade as Win32SelfUpgrade+import Paths_cabal_install (getBinDir)++import Distribution.Simple.Compiler+         ( CompilerId(..), Compiler(compilerId), PackageDB(..) )+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 )+import Distribution.Simple.Utils+         ( defaultPackageDesc, inDir, rawSystemExit, withTempDirectory )+import Distribution.Simple.InstallDirs+         ( fromPathTemplate, toPathTemplate+         , initialPathTemplateEnv, substPathTemplate )+import Distribution.Package+         ( PackageIdentifier(..), Package(..), thisPackageVersion+         , Dependency(..) )+import qualified Distribution.PackageDescription as PackageDescription+import Distribution.PackageDescription+         ( PackageDescription, readPackageDescription )+import Distribution.PackageDescription.Configuration+         ( finalizePackageDescription )+import Distribution.InstalledPackageInfo+         ( InstalledPackageInfo )+import Distribution.Version+         ( Version, VersionRange(AnyVersion, ThisVersion) )+import Distribution.Simple.Utils as Utils+         ( notice, info, warn, die, intercalate )+import Distribution.System+         ( OS(Windows), buildOS, Arch, buildArch )+import Distribution.Text+         ( display )+import Distribution.Verbosity as Verbosity+         ( Verbosity, showForCabal, verbose )+import Distribution.Simple.BuildPaths ( exeExtension )++data InstallMisc = InstallMisc {+    rootCmd    :: Maybe FilePath,+    libVersion :: Maybe Version+  }++-- |Installs the packages needed to satisfy a list of dependencies.+install, upgrade+  :: Verbosity+  -> PackageDB+  -> [Repo]+  -> Compiler+  -> ProgramConfiguration+  -> Cabal.ConfigFlags+  -> InstallFlags+  -> [UnresolvedDependency]+  -> IO ()+install verbosity packageDB repos comp conf configFlags installFlags deps =+  installWithPlanner planner+        verbosity packageDB repos comp conf configFlags installFlags+  where+    planner :: Planner+    planner | null deps = planLocalPackage verbosity comp configFlags+            | otherwise = planRepoPackages PreferLatestForSelected+                            comp installFlags deps++upgrade verbosity packageDB repos comp conf configFlags installFlags deps =+  installWithPlanner planner+        verbosity packageDB repos comp conf configFlags installFlags+  where+    planner :: Planner+    planner | null deps = planUpgradePackages comp+            | otherwise = planRepoPackages PreferAllLatest+                            comp installFlags deps++type Planner = Maybe (PackageIndex InstalledPackageInfo)+            -> PackageIndex AvailablePackage+            -> IO (Progress String String InstallPlan)++-- |Installs the packages generated by a planner.+installWithPlanner ::+           Planner+        -> Verbosity+        -> PackageDB+        -> [Repo]+        -> Compiler+        -> ProgramConfiguration+        -> Cabal.ConfigFlags+        -> InstallFlags+        -> IO ()+installWithPlanner planner verbosity packageDB repos comp conf configFlags installFlags = do+  installed <- getInstalledPackages verbosity comp packageDB conf+  available <- getAvailablePackages verbosity repos++  progress <- planner installed available++  notice verbosity "Resolving dependencies..."+  maybePlan <- foldProgress (\message rest -> info verbosity message >> rest)+                            (return . Left) (return . Right) progress+  case maybePlan of+    Left message -> die message+    Right installPlan -> do+      let nothingToInstall = null (InstallPlan.ready installPlan)+      when nothingToInstall $+        notice verbosity $+             "No packages to be installed. All the requested packages are "+          ++ "already installed.\n If you want to reinstall anyway then use "+          ++ "the --reinstall flag."++      when (dryRun || verbosity >= verbose) $+        printDryRun verbosity installPlan++      unless dryRun $ do+        logsDir <- defaultLogsDir+        let os     = InstallPlan.planOS installPlan+            arch   = InstallPlan.planArch installPlan+            compid = InstallPlan.planCompiler installPlan+        installPlan' <-+          executeInstallPlan installPlan $ \cpkg ->+            installConfiguredPackage os arch compid configFlags+                                     cpkg $ \configFlags' src pkg ->+              installAvailablePackage verbosity (packageId pkg) src $ \mpath ->+                installUnpackedPackage verbosity (setupScriptOptions installed)+                                       miscOptions configFlags' installFlags+                                       compid pkg mpath (useLogFile logsDir)++        let buildReports = BuildReports.fromInstallPlan installPlan'+        BuildReports.storeAnonymous buildReports+        BuildReports.storeLocal     buildReports+        when useDetailedBuildReports $+          storeDetailedBuildReports logsDir buildReports+        symlinkBinaries verbosity configFlags installFlags installPlan'+        printBuildFailures installPlan'++  where+    setupScriptOptions index = SetupScriptOptions {+      useCabalVersion  = maybe AnyVersion ThisVersion (libVersion miscOptions),+      useCompiler      = Just comp,+      usePackageIndex  = if packageDB == UserPackageDB then index else Nothing,+      useProgramConfig = conf,+      useDistPref      = Cabal.fromFlagOrDefault+                           (useDistPref defaultSetupScriptOptions)+                           (Cabal.configDistPref configFlags),+      useLoggingHandle = Nothing,+      useWorkingDir    = Nothing+    }+    useDetailedBuildReports = Cabal.fromFlagOrDefault False (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+      where env = initialPathTemplateEnv (packageId pkg) (compilerId comp)+    dryRun       = Cabal.fromFlagOrDefault False (installDryRun installFlags)+    miscOptions  = InstallMisc {+      rootCmd    = if Cabal.fromFlag (Cabal.configUserInstall configFlags)+                     then Nothing      -- ignore --root-cmd if --user.+                     else Cabal.flagToMaybe (installRootCmd installFlags),+      libVersion = Cabal.flagToMaybe (installCabalVersion installFlags)+    }++storeDetailedBuildReports :: FilePath -> [(BuildReports.BuildReport, Repo)] -> IO ()+storeDetailedBuildReports logsDir reports+    = forM_ reports $ \(report,repo) ->+      do buildLog <- readFile (logsDir </> display (BuildReports.package report) <.> "log")+         case repoKind repo of+           Left remoteRepo+                -> do dotCabal <- defaultCabalDir+                      let destDir = dotCabal </> "reports" </> remoteRepoName remoteRepo+                          dest = destDir </> display (BuildReports.package report) <.> "log"+                      createDirectoryIfMissing True destDir -- FIXME+                      writeFile dest (show (BuildReports.show report, buildLog))+           Right{} -> return ()+         ++-- | 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 available = do+  pkg <- readPackageDescription verbosity =<< defaultPackageDesc verbosity+  let -- The trick is, we add the local package to the available index and+      -- remove it from the installed index. Then we ask to resolve a+      -- dependency on exactly that package. So the resolver ends up having+      -- to pick the local package.+      available' = PackageIndex.insert localPkg available+      installed' = PackageIndex.deletePackageId (packageId localPkg) `fmap` installed+      localPkg = AvailablePackage {+        packageInfoId                = packageId pkg,+        Available.packageDescription = pkg,+        packageSource                = LocalUnpackedPackage+      }+      localPkgDep = UnresolvedDependency {+        dependency = thisPackageVersion (packageId localPkg),+        depFlags   = Cabal.configConfigurationsFlags configFlags+      }++  return $ resolveDependenciesWithProgress buildOS buildArch (compilerId comp)+             installed' available' PreferLatestForSelected [localPkgDep]++-- | Make an 'InstallPlan' for the given dependencies.+--+planRepoPackages :: PackagesVersionPreference -> Compiler -> InstallFlags+                 -> [UnresolvedDependency] -> Planner+planRepoPackages pref comp installFlags deps installed available = do+  deps' <- IndexUtils.disambiguateDependencies available deps+  let installed'+        | Cabal.fromFlagOrDefault False (installReinstall installFlags)+                    = fmap (hideGivenDeps deps') installed+        | otherwise = installed+  return $ resolveDependenciesWithProgress buildOS buildArch (compilerId comp)+             installed' available pref deps'+  where+    hideGivenDeps pkgs index =+      foldr PackageIndex.deletePackageName index+        [ name | UnresolvedDependency (Dependency name _) _ <- pkgs ]++planUpgradePackages :: Compiler -> Planner+planUpgradePackages comp (Just installed) available = return $+  resolveDependenciesWithProgress buildOS buildArch (compilerId comp)+    (Just installed) available PreferAllLatest+    [ UnresolvedDependency dep []+    | dep <- upgradableDependencies installed available ]+planUpgradePackages comp _ _ =+  die $ display (compilerId comp)+     ++ " does not track installed packages so cabal cannot figure out what"+     ++ " packages need to be upgraded."++printDryRun :: Verbosity -> InstallPlan -> IO ()+printDryRun verbosity plan = case unfoldr next plan of+  []   -> return ()+  pkgs -> notice verbosity $ unlines $+            "In order, the following would be installed:"+          : map display pkgs+  where+    next plan' = case InstallPlan.ready plan' of+      []      -> Nothing+      (pkg:_) -> Just (pkgid, InstallPlan.completed pkgid result plan')+        where pkgid = packageId pkg+              result = BuildOk DocsNotTried TestsNotTried+              --FIXME: This is a bit of a hack,+              -- pretending that each package is installed++symlinkBinaries :: Verbosity+                -> Cabal.ConfigFlags+                -> InstallFlags+                -> InstallPlan -> IO ()+symlinkBinaries verbosity configFlags installFlags plan = do+  failed <- InstallSymlink.symlinkBinaries configFlags installFlags plan+  case failed of+    [] -> return ()+    [(_, exe, path)] ->+      warn verbosity $+           "could not create a symlink in " ++ bindir ++ " for "+        ++ exe ++ " because the file exists there already but is not "+        ++ "managed by cabal. You can create a symlink for this executable "+        ++ "manually if you wish. The executable file has been installed at "+        ++ path+    exes ->+      warn verbosity $+           "could not create symlinks in " ++ bindir ++ " for "+        ++ intercalate ", " [ exe | (_, exe, _) <- exes ]+        ++ " because the files exist there already and are not "+        ++ "managed by cabal. You can create symlinks for these executables "+        ++ "manually if you wish. The executable files have been installed at "+        ++ intercalate ", " [ path | (_, _, path) <- exes ]+  where+    bindir = Cabal.fromFlag (installSymlinkBinDir installFlags)++printBuildFailures :: InstallPlan -> IO ()+printBuildFailures plan =+  case [ (pkg, reason)+       | InstallPlan.Failed pkg reason <- InstallPlan.toList plan ] of+    []     -> return ()+    failed -> die . unlines+            $ "Error: some packages failed to install:"+            : [ display (packageId pkg) ++ printFailureReason reason+              | (pkg, reason) <- failed ]+  where+    printFailureReason reason = case reason of+      DependentFailed pkgid -> " depends on " ++ display pkgid+                            ++ " which failed to install."+      UnpackFailed    e -> " failed while unpacking the package."+                        ++ " The exception was:\n  " ++ show e+      ConfigureFailed e -> " failed during the configure step."+                        ++ " The exception was:\n  " ++ show e+      BuildFailed     e -> " failed during the building phase."+                        ++ " The exception was:\n  " ++ show e+      InstallFailed   e -> " failed during the final install step."+                        ++ " The exception was:\n  " ++ show e++executeInstallPlan :: Monad m+                   => InstallPlan+                   -> (ConfiguredPackage -> m BuildResult)+                   -> m InstallPlan+executeInstallPlan plan installPkg = case InstallPlan.ready plan of+  []       -> return plan+  (pkg: _) -> do buildResult <- installPkg pkg+                 let plan' = updatePlan (packageId pkg) buildResult plan+                 executeInstallPlan plan' installPkg+  where+    updatePlan pkgid (Right buildSuccess) =+      InstallPlan.completed pkgid buildSuccess++    updatePlan pkgid (Left buildFailure) =+      InstallPlan.failed    pkgid buildFailure depsFailure+      where+        depsFailure = DependentFailed pkgid+        -- So this first pkgid failed for whatever reason (buildFailure).+        -- All the other packages that depended on this pkgid, which we+        -- now cannot build, we mark as failing due to 'DependentFailed'+        -- which kind of means it was not their fault.++-- | Call an installer for an 'AvailablePackage' but override the configure+-- flags with the ones given by the 'ConfiguredPackage'. In particular the+-- 'ConfiguredPackage' specifies an exact 'FlagAssignment' and exactly+-- 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)+                         -> a+installConfiguredPackage os arch comp configFlags+  (ConfiguredPackage (AvailablePackage _ gpkg source) flags deps)+  installPkg = installPkg configFlags {+    Cabal.configConfigurationsFlags = flags,+    Cabal.configConstraints = map thisPackageVersion deps+  } source pkg+  where+    pkg = case finalizePackageDescription flags+           (Nothing :: Maybe (PackageIndex PackageDescription))+           os arch comp [] gpkg of+      Left _ -> error "finalizePackageDescription ConfiguredPackage failed"+      Right (desc, _) -> desc++installAvailablePackage+  :: Verbosity -> PackageIdentifier -> AvailablePackageSource+  -> (Maybe FilePath -> IO BuildResult)+  -> IO BuildResult+installAvailablePackage _ _ LocalUnpackedPackage installPkg =+  installPkg Nothing++installAvailablePackage verbosity pkgid (RepoTarballPackage repo) installPkg = 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+                                  </> pkgName pkgid <.> "cabal"+    exists <- doesFileExist descFilePath+    when (not exists) $+      die $ "Package .cabal file not found: " ++ show descFilePath+    installPkg (Just path)++installUnpackedPackage :: Verbosity+                   -> SetupScriptOptions+                   -> InstallMisc+                   -> Cabal.ConfigFlags+                   -> InstallFlags+                   -> CompilerId+                   -> PackageDescription+                   -> Maybe FilePath -- ^ Directory to change to before starting the installation.+                   -> Maybe (PackageIdentifier -> FilePath) -- ^ File to log output to (if any)+                   -> IO BuildResult+installUnpackedPackage verbosity scriptOptions miscOptions+                       configFlags installConfigFlags+                       compid pkg workingDir useLogFile =++  -- Configure phase+  onFailure ConfigureFailed $ do+    setup configureCommand configureFlags++  -- Build phase+    onFailure BuildFailed $ do+      setup buildCommand buildFlags++  -- Doc generation phase+      docsResult <- if shouldHaddock+        then Exception.handle (\_ -> return DocsFailed) $ do+               setup Cabal.haddockCommand haddockFlags+               return DocsOk+        else return DocsNotTried++  -- Tests phase+      testsResult <- return TestsNotTried  --TODO: add optional tests++  -- Install phase+      onFailure InstallFailed $+        withWin32SelfUpgrade verbosity configFlags compid pkg $ do+          case rootCmd miscOptions of+            (Just cmd) -> reexec cmd+            Nothing    -> setup Cabal.installCommand installFlags+          return (Right (BuildOk docsResult testsResult))++  where+    configureFlags   = filterConfigureFlags configFlags {+      Cabal.configVerbosity = Cabal.toFlag verbosity'+    } +    buildCommand     = Cabal.buildCommand defaultProgramConfiguration+    buildFlags   _   = Cabal.emptyBuildFlags {+      Cabal.buildDistPref  = Cabal.configDistPref configFlags,+      Cabal.buildVerbosity = Cabal.toFlag verbosity'+    }+    shouldHaddock    = Cabal.fromFlagOrDefault False+                         (installDocumentation installConfigFlags)+    haddockFlags _   = Cabal.emptyHaddockFlags {+      Cabal.haddockDistPref  = Cabal.configDistPref configFlags,+      Cabal.haddockVerbosity = Cabal.toFlag verbosity'+    }+    installFlags _   = Cabal.emptyInstallFlags {+      Cabal.installDistPref  = Cabal.configDistPref configFlags,+      Cabal.installVerbosity = Cabal.toFlag verbosity'+    }+    verbosity' | isJust useLogFile = max Verbosity.verbose verbosity+               | otherwise         = verbosity+    setup cmd flags  = do+      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)++      setupWrapper verbosity+        scriptOptions { useLoggingHandle = logFileHandle+                      , useWorkingDir    = workingDir }+        (Just pkg)+        cmd flags []+    reexec cmd = do+      -- look for our on executable file and re-exec ourselves using+      -- a helper program like sudo to elevate priviledges:+      bindir <- getBinDir+      let self = bindir </> "cabal" <.> exeExtension+      weExist <- doesFileExist self+      if weExist+        then inDir workingDir $+               rawSystemExit verbosity cmd+                 [self, "install", "--only"+                 ,"--verbose=" ++ showForCabal verbosity]+        else die $ "Unable to find cabal executable at: " ++ self++-- helper+onFailure :: (Exception -> BuildFailure) -> IO BuildResult -> IO BuildResult+onFailure result = Exception.handle (return . Left . result)+++withWin32SelfUpgrade :: Verbosity+                     -> Cabal.ConfigFlags+                     -> CompilerId+                     -> PackageDescription+                     -> IO a -> IO a+withWin32SelfUpgrade _ _ _ _ action | buildOS /= Windows = action+withWin32SelfUpgrade verbosity configFlags compid pkg action = do++  defaultDirs <- InstallDirs.defaultInstallDirs+                   compilerFlavor+                   (Cabal.fromFlag (Cabal.configUserInstall configFlags))+                   (PackageDescription.hasLibs pkg)++  Win32SelfUpgrade.possibleSelfUpgrade verbosity+    (exeInstallPaths defaultDirs) action++  where+    pkgid = packageId pkg+    (CompilerId compilerFlavor _) = compid++    exeInstallPaths defaultDirs =+      [ InstallDirs.bindir absoluteDirs </> exeName <.> exeExtension+      | exe <- PackageDescription.executables pkg+      , PackageDescription.buildable (PackageDescription.buildInfo exe)+      , let exeName = prefix ++ PackageDescription.exeName exe ++ suffix+            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)+        absoluteDirs   = InstallDirs.absoluteInstallDirs+                           pkgid compid InstallDirs.NoCopyDest templateDirs+        substTemplate  = InstallDirs.fromPathTemplate+                       . InstallDirs.substPathTemplate env+          where env = InstallDirs.initialPathTemplateEnv pkgid compid
+ Distribution/Client/InstallPlan.hs view
@@ -0,0 +1,498 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.InstallPlan+-- Copyright   :  (c) Duncan Coutts 2008+-- License     :  BSD-like+--+-- Maintainer  :  duncan@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- Package installation plan+--+-----------------------------------------------------------------------------+module Distribution.Client.InstallPlan (+  InstallPlan,+  ConfiguredPackage(..),+  PlanPackage(..),++  -- * Operations on 'InstallPlan's+  new,+  toList,+  ready,+  completed,+  failed,++  -- ** Query functions+  planOS,+  planArch,+  planCompiler,++  -- * Checking valididy of plans+  valid,+  closed,+  consistent,+  acyclic,+  configuredPackageValid,++  -- ** Details on invalid plans+  PlanProblem(..),+  showPlanProblem,+  PackageProblem(..),+  showPackageProblem,+  problems,+  configuredPackageProblems+  ) where++import Distribution.Client.Types+         ( AvailablePackage(packageDescription), ConfiguredPackage(..)+         , BuildFailure, BuildSuccess )+import Distribution.Package+         ( PackageIdentifier(..), Package(..), PackageFixedDeps(..)+         , packageName, Dependency(..) )+import Distribution.Version+         ( Version, withinRange )+import Distribution.InstalledPackageInfo+         ( InstalledPackageInfo )+import Distribution.PackageDescription+         ( GenericPackageDescription(genPackageFlags)+         , PackageDescription(buildDepends)+         , Flag(flagName), FlagName(..) )+import Distribution.PackageDescription.Configuration+         ( finalizePackageDescription )+import Distribution.Simple.PackageIndex+         ( PackageIndex )+import qualified Distribution.Simple.PackageIndex as PackageIndex+import Distribution.Text+         ( display )+import Distribution.System+         ( OS, Arch )+import Distribution.Compiler+         ( CompilerId(..) )+import Distribution.Client.Utils+         ( duplicates, duplicatesBy, mergeBy, MergeResult(..) )+import Distribution.Simple.Utils+         ( comparing, intercalate )++import Data.List+         ( sort, sortBy )+import Data.Maybe+         ( fromMaybe )+import qualified Data.Graph as Graph+import Data.Graph (Graph)+import Control.Exception+         ( assert )++-- When cabal tries to install a number of packages, including all their+-- dependencies it has a non-trivial problem to solve.+--+-- The Problem:+--+-- In general we start with a set of installed packages and a set of available+-- packages.+--+-- Installed packages have fixed dependencies. They have already been built and+-- we know exactly what packages they were built against, including their exact+-- versions. +--+-- Available package have somewhat flexible dependencies. They are specified as+-- version ranges, though really they're predicates. To make matters worse they+-- have conditional flexible dependencies. Configuration flags can affect which+-- packages are required and can place additional constraints on their+-- versions.+--+-- These two sets of package can and usually do overlap. There can be installed+-- packages that are also available which means they could be re-installed if+-- required, though there will also be packages which are not available and+-- cannot be re-installed. Very often there will be extra versions available+-- than are installed. Sometimes we may like to prefer installed packages over+-- available ones or perhaps always prefer the latest available version whether+-- installed or not.+--+-- The goal is to calculate an installation plan that is closed, acyclic and+-- consistent and where every configured package is valid.+--+-- An installation plan is a set of packages that are going to be used+-- together. It will consist of a mixture of installed packages and available+-- packages along with their exact version dependencies. An installation plan+-- is closed if for every package in the set, all of its dependencies are+-- also in the set. It is consistent if for every package in the set, all+-- dependencies which target that package have the same version.++-- Note that plans do not necessarily compose. You might have a valid plan for+-- package A and a valid plan for package B. That does not mean the composition+-- is simultaniously valid for A and B. In particular you're most likely to+-- have problems with inconsistent dependencies.+-- On the other hand it is true that every closed sub plan is valid.++data PlanPackage = PreExisting InstalledPackageInfo+                 | Configured  ConfiguredPackage+                 | Installed   ConfiguredPackage BuildSuccess+                 | Failed      ConfiguredPackage BuildFailure++instance Package PlanPackage where+  packageId (PreExisting pkg) = packageId pkg+  packageId (Configured  pkg) = packageId pkg+  packageId (Installed pkg _) = packageId pkg+  packageId (Failed    pkg _) = packageId pkg++instance PackageFixedDeps PlanPackage where+  depends (PreExisting pkg) = depends pkg+  depends (Configured  pkg) = depends pkg+  depends (Installed pkg _) = depends pkg+  depends (Failed    pkg _) = depends pkg++data InstallPlan = InstallPlan {+    planIndex    :: PackageIndex PlanPackage,+    planGraph    :: Graph,+    planGraphRev :: Graph,+    planPkgIdOf  :: Graph.Vertex -> PackageIdentifier,+    planVertexOf :: PackageIdentifier -> Graph.Vertex,+    planOS       :: OS,+    planArch     :: Arch,+    planCompiler :: CompilerId+  }++invariant :: InstallPlan -> Bool+invariant plan =+  valid (planOS plan) (planArch 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+    -> Either [PlanProblem] InstallPlan+new os arch compiler index =+  case problems os arch compiler index of+    [] -> Right InstallPlan {+            planIndex    = index,+            planGraph    = graph,+            planGraphRev = Graph.transposeG graph,+            planPkgIdOf  = vertexToPkgId,+            planVertexOf = fromMaybe noSuchPkgId . pkgIdToVertex,+            planOS       = os,+            planArch     = arch,+            planCompiler = compiler+          }+      where (graph, vertexToPkgId, pkgIdToVertex) =+              PackageIndex.dependencyGraph index+            noSuchPkgId = internalError "package is not in the graph"+    probs -> Left probs++toList :: InstallPlan -> [PlanPackage]+toList = PackageIndex.allPackages . planIndex++-- | The packages that are ready to be installed. That is they are in the+-- configured state and have all their dependencies installed already.+-- The plan is complete if the result is @[]@.+--+ready :: InstallPlan -> [ConfiguredPackage]+ready plan = assert check readyPackages+  where+    check = if null readyPackages then null configuredPackages else True+    configuredPackages =+      [ pkg | Configured pkg <- PackageIndex.allPackages (planIndex plan) ]+    readyPackages = filter (all isInstalled . depends) configuredPackages+    isInstalled pkg =+      case PackageIndex.lookupPackageId (planIndex plan) pkg of+        Just (Configured  _) -> False+        Just (Failed    _ _) -> internalError depOnFailed+        Just (PreExisting _) -> True+        Just (Installed _ _) -> True+        Nothing              -> internalError incomplete+    incomplete  = "install plan is not closed"+    depOnFailed = "configured package depends on failed package"++-- | Marks a package in the graph as completed. Also saves the build result for+-- the completed package in the plan.+--+-- * The package must exist in the graph.+-- * The package must have had no uninstalled dependent packages.+--+completed :: PackageIdentifier+          -> BuildSuccess+          -> InstallPlan -> InstallPlan+completed pkgid buildResult plan = assert (invariant plan') plan'+  where+    plan'     = plan {+                  planIndex = PackageIndex.insert installed (planIndex plan)+                }+    installed = Installed (lookupConfiguredPackage plan pkgid) buildResult++-- | Marks a package in the graph as having failed. It also marks all the+-- packages that depended on it as having failed.+--+-- * The package must exist in the graph and be in the configured state.+--+failed :: PackageIdentifier -- ^ The id of the package that failed to install+       -> BuildFailure      -- ^ The build result to use for the failed package+       -> BuildFailure      -- ^ The build result to use for its dependencies+       -> InstallPlan+       -> InstallPlan+failed pkgid buildResult buildResult' plan = assert (invariant plan') plan'+  where+    plan'    = plan {+                 planIndex = PackageIndex.merge (planIndex plan) failures+               }+    pkg      = lookupConfiguredPackage plan pkgid+    failures = PackageIndex.fromList+             $ Failed pkg buildResult+             : [ Failed pkg' buildResult'+               | Just pkg' <- map (lookupConfiguredPackage' plan)+                            $ packagesThatDependOn plan pkgid ]++-- | lookup the reachable packages in the reverse dependency graph+--+packagesThatDependOn :: InstallPlan+                     -> PackageIdentifier -> [PackageIdentifier]+packagesThatDependOn plan = map (planPkgIdOf plan)+                          . tail+                          . Graph.reachable (planGraphRev plan)+                          . planVertexOf plan++-- | lookup a package that we expect to be in the configured state+--+lookupConfiguredPackage :: InstallPlan+                        -> PackageIdentifier -> ConfiguredPackage+lookupConfiguredPackage plan pkgid =+  case PackageIndex.lookupPackageId (planIndex plan) pkgid of+    Just (Configured pkg) -> pkg+    _  -> internalError $ "not configured or no such pkg " ++ display pkgid++-- | lookup a package that we expect to be in the configured or failed state+--+lookupConfiguredPackage' :: InstallPlan+                         -> PackageIdentifier -> Maybe ConfiguredPackage+lookupConfiguredPackage' plan pkgid =+  case PackageIndex.lookupPackageId (planIndex plan) pkgid of+    Just (Configured pkg) -> Just pkg+    Just (Failed _ _)     -> Nothing+    _  -> internalError $ "not configured or no such pkg " ++ display pkgid++-- ------------------------------------------------------------+-- * Checking valididy of plans+-- ------------------------------------------------------------++-- | A valid installation plan is a set of packages that is 'acyclic',+-- 'closed' and 'consistent'. Also, every 'ConfiguredPackage' in the+-- plan has to have a valid configuration (see 'configuredPackageValid').+--+-- * 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)++data PlanProblem =+     PackageInvalid       ConfiguredPackage [PackageProblem]+   | PackageMissingDeps   PlanPackage [PackageIdentifier]+   | PackageCycle         [PlanPackage]+   | PackageInconsistency String [(PackageIdentifier, Version)]+   | PackageStateInvalid  PlanPackage PlanPackage++showPlanProblem :: PlanProblem -> String+showPlanProblem (PackageInvalid pkg packageProblems) =+     "Package " ++ display (packageId pkg)+  ++ " has an invalid configuration, in particular:\n"+  ++ unlines [ "  " ++ showPackageProblem problem+             | problem <- packageProblems ]++showPlanProblem (PackageMissingDeps pkg missingDeps) =+     "Package " ++ display (packageId pkg)+  ++ " depends on the following packages which are missing from the plan "+  ++ intercalate ", " (map display missingDeps)++showPlanProblem (PackageCycle cycleGroup) =+     "The following packages are involved in a dependency cycle "+  ++ intercalate ", " (map (display.packageId) cycleGroup)++showPlanProblem (PackageInconsistency name inconsistencies) =+     "Package " ++ name+  ++ " is required by several packages,"+  ++ " but they require inconsistent versions:\n"+  ++ unlines [ "  package " ++ display pkg ++ " requires "+                            ++ display (PackageIdentifier name ver)+             | (pkg, ver) <- inconsistencies ]++showPlanProblem (PackageStateInvalid pkg pkg') =+     "Package " ++ display (packageId pkg)+  ++ " is in the " ++ showPlanState pkg+  ++ " state but it depends on package " ++ display (packageId pkg')+  ++ " which is in the " ++ showPlanState pkg'+  ++ " state"+  where+    showPlanState (PreExisting _) = "pre-existing"+    showPlanState (Configured  _) = "configured"+    showPlanState (Installed _ _) = "installed"+    showPlanState (Failed    _ _) = "failed"++-- | For an invalid plan, produce a detailed list of problems as human readable+-- error messages. This is mainly intended for debugging purposes.+-- Use 'showPlanProblem' for a human readable explanation.+--+problems :: OS -> Arch -> CompilerId+         -> PackageIndex PlanPackage -> [PlanProblem]+problems os arch comp index =+     [ PackageInvalid pkg packageProblems+     | Configured pkg <- PackageIndex.allPackages index+     , let packageProblems = configuredPackageProblems os arch comp pkg+     , not (null packageProblems) ]++  ++ [ PackageMissingDeps pkg missingDeps+     | (pkg, missingDeps) <- PackageIndex.brokenPackages index ]++  ++ [ PackageCycle cycleGroup+     | cycleGroup <- PackageIndex.dependencyCycles index ]++  ++ [ PackageInconsistency name inconsistencies+     | (name, inconsistencies) <- PackageIndex.dependencyInconsistencies index ]++  ++ [ PackageStateInvalid pkg pkg'+     | pkg <- PackageIndex.allPackages index+     , Just pkg' <- map (PackageIndex.lookupPackageId index) (depends pkg)+     , not (stateDependencyRelation pkg pkg') ]++-- | The graph of packages (nodes) and dependencies (edges) must be acyclic.+--+-- * if the result is @False@ use 'PackageIndex.dependencyCycles' to find out+--   which packages are involved in dependency cycles.+--+acyclic :: PackageIndex PlanPackage -> Bool+acyclic = null . PackageIndex.dependencyCycles++-- | An installation plan is closed if for every package in the set, all of+-- its dependencies are also in the set. That is, the set is closed under the+-- dependency relation.+--+-- * if the result is @False@ use 'PackageIndex.brokenPackages' to find out+--   which packages depend on packages not in the index.+--+closed :: PackageIndex PlanPackage -> Bool+closed = null . PackageIndex.brokenPackages++-- | An installation plan is consistent if all dependencies that target a+-- single package name, target the same version.+--+-- This is slightly subtle. It is not the same as requiring that there be at+-- most one version of any package in the set. It only requires that of+-- packages which have more than one other package depending on them. We could+-- actually make the condition even more precise and say that different+-- versions are ok so long as they are not both in the transative closure of+-- any other package (or equivalently that their inverse closures do not+-- intersect). The point is we do not want to have any packages depending+-- directly or indirectly on two different versions of the same package. The+-- current definition is just a safe aproximation of that.+--+-- * if the result is @False@ use 'PackageIndex.dependencyInconsistencies' to+--   find out which packages are.+--+consistent :: PackageIndex PlanPackage -> Bool+consistent = null . PackageIndex.dependencyInconsistencies++-- | The states of packages have that depend on each other must respect+-- this relation. That is for very case where package @a@ depends on+-- package @b@ we require that @dependencyStatesOk a b = True@.+--+stateDependencyRelation :: PlanPackage -> PlanPackage -> Bool+stateDependencyRelation (PreExisting _) (PreExisting _) = True++stateDependencyRelation (Configured  _) (PreExisting _) = True+stateDependencyRelation (Configured  _) (Configured  _) = True+stateDependencyRelation (Configured  _) (Installed _ _) = True++stateDependencyRelation (Installed _ _) (PreExisting _) = True+stateDependencyRelation (Installed _ _) (Installed _ _) = True++stateDependencyRelation (Failed    _ _) (PreExisting _) = True+-- failed can depends on configured because a package can depend on+-- several other packages and if one of the deps fail then we fail+-- but we still depend on the other ones that did not fail:+stateDependencyRelation (Failed    _ _) (Configured  _) = True+stateDependencyRelation (Failed    _ _) (Installed _ _) = True+stateDependencyRelation (Failed    _ _) (Failed    _ _) = True++stateDependencyRelation _               _               = False++-- | A 'ConfiguredPackage' is valid if the flag assignment is total and if+-- 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)++data PackageProblem = DuplicateFlag FlagName+                    | MissingFlag   FlagName+                    | ExtraFlag     FlagName+                    | DuplicateDeps [PackageIdentifier]+                    | MissingDep    Dependency+                    | ExtraDep      PackageIdentifier+                    | InvalidDep    Dependency PackageIdentifier++showPackageProblem :: PackageProblem -> String+showPackageProblem (DuplicateFlag (FlagName flag)) =+  "duplicate flag in the flag assignment: " ++ flag++showPackageProblem (MissingFlag (FlagName flag)) =+  "missing an assignment for the flag: " ++ flag++showPackageProblem (ExtraFlag (FlagName flag)) =+  "extra flag given that is not used by the package: " ++ flag++showPackageProblem (DuplicateDeps pkgids) =+     "duplicate packages specified as selected dependencies: "+  ++ intercalate ", " (map display pkgids)++showPackageProblem (MissingDep dep) =+     "the package has a dependency " ++ display dep+  ++ " but no package has been selected to satisfy it."++showPackageProblem (ExtraDep pkgid) =+     "the package configuration specifies " ++ display pkgid+  ++ " but (with the given flag assignment) the package does not actually"+  ++ " depend on any version of that package."++showPackageProblem (InvalidDep dep pkgid) =+     "the package depends on " ++ display dep+  ++ " but the configuration specifies " ++ display pkgid+  ++ " which does not satisfy the dependency."++configuredPackageProblems :: OS -> Arch -> CompilerId+                          -> ConfiguredPackage -> [PackageProblem]+configuredPackageProblems os arch comp+  (ConfiguredPackage pkg specifiedFlags specifiedDeps) =+     [ DuplicateFlag flag | ((flag,_):_) <- duplicates specifiedFlags ]+  ++ [ MissingFlag flag | OnlyInLeft  flag <- mergedFlags ]+  ++ [ ExtraFlag   flag | OnlyInRight flag <- mergedFlags ]+  ++ [ DuplicateDeps pkgs+     | pkgs <- duplicatesBy (comparing packageName) specifiedDeps ]+  ++ [ MissingDep dep       | OnlyInLeft  dep       <- mergedDeps ]+  ++ [ ExtraDep       pkgid | OnlyInRight     pkgid <- mergedDeps ]+  ++ [ InvalidDep dep pkgid | InBoth      dep pkgid <- mergedDeps+                            , not (packageSatisfiesDependency pkgid dep) ]+  where+    mergedFlags = mergeBy compare+      (sort $ map flagName (genPackageFlags (packageDescription pkg)))+      (sort $ map fst specifiedFlags)++    mergedDeps = mergeBy+      (\dep pkgid -> dependencyName dep `compare` packageName pkgid)+      (sortBy (comparing dependencyName) requiredDeps)+      (sortBy (comparing packageName)    specifiedDeps)++    packageSatisfiesDependency+      (PackageIdentifier name  version)+      (Dependency        name' versionRange) = assert (name == name') $+        version `withinRange` versionRange++    dependencyName (Dependency name _) = name++    requiredDeps :: [Dependency]+    requiredDeps =+      --TODO: use something lower level than finalizePackageDescription+      case finalizePackageDescription specifiedFlags+         (Nothing :: Maybe (PackageIndex PackageIdentifier)) os arch comp []+         (packageDescription pkg) of+        Right (resolvedPkg, _) -> buildDepends resolvedPkg+        Left  _ -> error "configuredPackageInvalidDeps internal error"
+ Distribution/Client/InstallSymlink.hs view
@@ -0,0 +1,239 @@+{-# OPTIONS -cpp #-}+-- OPTIONS required for ghc-6.4.x compat, and must appear first+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -cpp #-}+{-# OPTIONS_NHC98 -cpp #-}+{-# OPTIONS_JHC -fcpp  #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.InstallSymlink+-- Copyright   :  (c) Duncan Coutts 2008+-- License     :  BSD-like+--+-- Maintainer  :  cabal-devel@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- Managing installing binaries with symlinks.+-----------------------------------------------------------------------------+module Distribution.Client.InstallSymlink (+    symlinkBinaries,+    symlinkBinary,+  ) where++#if mingw32_HOST_OS || mingw32_TARGET_OS++import Distribution.Package (PackageIdentifier)+import Distribution.Client.InstallPlan (InstallPlan)+import Distribution.Client.Setup (InstallFlags)+import Distribution.Simple.Setup (ConfigFlags)++symlinkBinaries :: ConfigFlags+                -> InstallFlags+                -> InstallPlan+                -> IO [(PackageIdentifier, String, FilePath)]+symlinkBinaries _ _ _ = return []++symlinkBinary :: FilePath -> FilePath -> String -> String -> IO Bool+symlinkBinary _ _ _ _ = fail "Symlinking feature not available on Windows"++#else++import Distribution.Client.Types+         ( AvailablePackage(..), ConfiguredPackage(..) )+import Distribution.Client.Setup+         ( InstallFlags(installSymlinkBinDir) )+import qualified Distribution.Client.InstallPlan as InstallPlan+import Distribution.Client.InstallPlan (InstallPlan)++import Distribution.Package+         ( PackageIdentifier, Package(packageId) )+import Distribution.Compiler+         ( CompilerId(..) )+import qualified Distribution.PackageDescription as PackageDescription+import Distribution.PackageDescription+         ( PackageDescription )+import Distribution.PackageDescription.Configuration+         ( finalizePackageDescription )+import Distribution.Simple.Setup+         ( ConfigFlags(..), fromFlag, fromFlagOrDefault, flagToMaybe )+import qualified Distribution.Simple.InstallDirs as InstallDirs+import Distribution.Simple.PackageIndex (PackageIndex)++import System.Posix.Files+         ( getSymbolicLinkStatus, isSymbolicLink, readSymbolicLink+         , createSymbolicLink, removeLink )+import System.Directory+         ( canonicalizePath )+import System.FilePath+         ( (</>), takeDirectory, splitPath, joinPath, isAbsolute )+import System.IO.Error+         ( catch, isDoesNotExistError, ioError )+import Control.Exception+         ( assert )+import Data.Maybe+         ( catMaybes )++-- | We would like by default to install binaries into some location that is on+-- the user's PATH. For per-user installations on Unix systems that basically+-- means the @~/bin/@ directory. On the majority of platforms the @~/bin/@+-- directory will be on the user's PATH. However some people are a bit nervous+-- about letting a package manager install programs into @~/bin/@.+--+-- A comprimise solution is that instead of installing binaries directly into+-- @~/bin/@, we could install them in a private location under @~/.cabal/bin@+-- and then create symlinks in @~/bin/@. We can be careful when setting up the+-- symlinks that we do not overwrite any binary that the user installed. We can+-- check if it was a symlink we made because it would point to the private dir+-- where we install our binaries. This means we can install normally without+-- worrying and in a later phase set up symlinks, and if that fails then we+-- report it to the user, but even in this case the package is still in an ok+-- installed state.+--+-- This is an optional feature that users can choose to use or not. It is+-- controlled from the config file. Of course it only works on posix systems+-- with symlinks so is not available to Windows users.+--+symlinkBinaries :: ConfigFlags+                -> InstallFlags+                -> InstallPlan+                -> IO [(PackageIdentifier, String, FilePath)]+symlinkBinaries configFlags installFlags plan =+  case flagToMaybe (installSymlinkBinDir installFlags) of+    Nothing            -> return []+    Just symlinkBinDir+           | null exes -> return []+           | otherwise -> do+      publicBinDir  <- canonicalizePath symlinkBinDir+--    TODO: do we want to do this here? :+--      createDirectoryIfMissing True publicBinDir+      fmap catMaybes $ sequence+        [ do privateBinDir <- pkgBinDir pkg+             ok <- symlinkBinary+                     publicBinDir  privateBinDir+                     publicExeName privateExeName+             if ok+               then return Nothing+               else return (Just (pkgid, publicExeName,+                                  privateBinDir </> privateExeName))+        | (pkg, exe) <- exes+        , let publicExeName  = PackageDescription.exeName exe+              privateExeName = prefix ++ publicExeName ++ suffix+              pkgid  = packageId pkg+              prefix = substTemplate pkgid prefixTemplate+              suffix = substTemplate pkgid suffixTemplate ]+  where+    exes =+      [ (pkg, exe)+      | InstallPlan.Installed cpkg _ <- InstallPlan.toList plan+      , let pkg   = pkgDescription cpkg+      , exe <- PackageDescription.executables pkg+      , PackageDescription.buildable (PackageDescription.buildInfo exe) ]++    pkgDescription :: ConfiguredPackage -> PackageDescription+    pkgDescription (ConfiguredPackage (AvailablePackage _ pkg _) flags _) =+      case finalizePackageDescription flags+             (Nothing :: Maybe (PackageIndex PackageDescription))+             os arch compilerId [] pkg of+        Left _ -> error "finalizePackageDescription ConfiguredPackage failed"+        Right (desc, _) -> desc++    -- This is sadly rather complicated. We're kind of re-doing part of the+    -- configuration for the package. :-(+    pkgBinDir :: PackageDescription -> IO FilePath+    pkgBinDir pkg = do+      defaultDirs <- InstallDirs.defaultInstallDirs+                       compilerFlavor+                       (fromFlag (configUserInstall configFlags))+                       (PackageDescription.hasLibs pkg)+      let templateDirs = InstallDirs.combineInstallDirs fromFlagOrDefault+                           defaultDirs (configInstallDirs configFlags)+          absoluteDirs = InstallDirs.absoluteInstallDirs+                           (packageId pkg) compilerId InstallDirs.NoCopyDest+                           templateDirs+      canonicalizePath (InstallDirs.bindir absoluteDirs)++    substTemplate pkgid = InstallDirs.fromPathTemplate+                        . InstallDirs.substPathTemplate env+      where env = InstallDirs.initialPathTemplateEnv pkgid compilerId++    fromFlagTemplate = fromFlagOrDefault (InstallDirs.toPathTemplate "")+    prefixTemplate   = fromFlagTemplate (configProgPrefix configFlags)+    suffixTemplate   = fromFlagTemplate (configProgSuffix configFlags)+    os   = InstallPlan.planOS plan+    arch = InstallPlan.planArch plan+    compilerId@(CompilerId compilerFlavor _) = InstallPlan.planCompiler plan++symlinkBinary :: FilePath -- ^ The canonical path of the public bin dir+                          --   eg @/home/user/bin@+              -> FilePath -- ^ The canonical path of the private bin dir+                          --   eg @/home/user/.cabal/bin@+              -> String   -- ^ The name of the executable to go in the public+                          --   bin dir, eg @foo@+              -> String   -- ^ The name of the executable to in the private bin+                          --   dir, eg @foo-1.0@+              -> IO Bool  -- ^ If creating the symlink was sucessful. @False@+                          --   if there was another file there already that we+                          --   did not own. Other errors like permission errors+                          --   just propagate as exceptions.+symlinkBinary publicBindir privateBindir publicName privateName = do+  ok <- targetOkToOverwrite (publicBindir </> publicName) privateBindir+  case ok of+    NotOurFile    ->                     return False+    NotExists     ->           mkLink >> return True+    OkToOverwrite -> rmLink >> mkLink >> return True+  where+    relativeBindir = makeRelative publicBindir privateBindir+    mkLink = createSymbolicLink (relativeBindir </> privateName)+                                (publicBindir   </> publicName)+    rmLink = removeLink (publicBindir </> publicName)++-- | Check a filepath of a symlink that we would like to create to see if it+-- is ok. For it to be ok to overwrite it must either not already exist yet or+-- be a symlink to our private bin dir (in which case we can assume ownership).+--+targetOkToOverwrite :: FilePath -- ^ The filepath of the symlink to the private+                                -- binary that we would like to create+                    -> FilePath -- ^ The canonical path of the private bin+                                -- directory. Use 'canonicalizePath'.+                    -> IO SymlinkStatus+targetOkToOverwrite symlink privateBinDir = handleNotExist $ do+  status <- getSymbolicLinkStatus symlink+  if not (isSymbolicLink status)+    then return NotOurFile+    else return+       . (\ok -> if ok then OkToOverwrite else NotOurFile)+       . (== privateBinDir)+       . takeDirectory+     =<< canonicalizePath+       . (symlink </>)+     =<< readSymbolicLink symlink++  where+    handleNotExist action = catch action $ \ioexception ->+      -- If the target doesn't exist then there's no problem overwriting it!+      if isDoesNotExistError ioexception+        then return NotExists+        else ioError ioexception++data SymlinkStatus+   = NotExists     -- ^ The file doesn't exist so we can make a symlink.+   | OkToOverwrite -- ^ A symlink already exists, though it is ours. We'll+                   -- have to delete it first bemore we make a new symlink.+   | NotOurFile    -- ^ A file already exists and it is not one of our existing+                   -- symlinks (either because it is not a symlink or because+                   -- it points somewhere other than our managed space).+  deriving Show++-- | Take two canonical paths and produce a relative path to get from the first+-- to the second, even if it means adding @..@ path components.+--+makeRelative :: FilePath -> FilePath -> FilePath+makeRelative a b = assert (isAbsolute a && isAbsolute b) $+  let as = splitPath a+      bs = splitPath b+      commonLen = length $ takeWhile id $ zipWith (==) as bs+   in joinPath $ [ ".." | _  <- drop commonLen as ]+              ++ [  b'  | b' <- drop commonLen bs ]++#endif
+ Distribution/Client/List.hs view
@@ -0,0 +1,181 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Install+-- Copyright   :  (c) David Himmelstrup 2005+-- License     :  BSD-like+--+-- Maintainer  :  lemmih@gmail.com+-- Stability   :  provisional+-- Portability :  portable+--+-- High level interface to package installation.+-----------------------------------------------------------------------------+module Distribution.Client.List (+  list+  ) 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(..), Package(..))+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 Distribution.Client.IndexUtils (getAvailablePackages)+import Distribution.Client.Setup (ListFlags(..))+import Distribution.Client.Types (AvailablePackage(..), Repo)+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 Distribution.Client.Utils (mergeBy, MergeResult(..))++-- |Show information about packages+list :: Verbosity+     -> PackageDB+     -> [Repo]+     -> Compiler+     -> ProgramConfiguration+     -> ListFlags+     -> [String]+     -> IO ()+list verbosity packageDB repos comp conf listFlags pats = do+    Just installed <- getInstalledPackages verbosity comp packageDB conf+    available <- getAvailablePackages verbosity repos+    let pkgs | null pats = (PackageIndex.allPackages installed+                           ,PackageIndex.allPackages available)+             | otherwise =+                 (concatMap (PackageIndex.searchByNameSubstring installed) pats+                 ,concatMap (PackageIndex.searchByNameSubstring available) pats)+        matches = installedFilter+                . map (uncurry mergePackageInfo)+                $ uncurry mergePackages pkgs++    if simpleOutput+      then putStr $ unlines+             [ name pkg ++ " " ++ display version+             | pkg <- matches+             , version <- if onlyInstalled+                            then              installedVersions pkg+                            else nub . sort $ installedVersions pkg+                                           ++ availableVersions pkg ]+      else+        if null matches+            then notice verbosity "No matches found."+            else putStr $ unlines (map showPackageInfo matches)+  where+    installedFilter+      | onlyInstalled = filter (not . null . installedVersions)+      | otherwise     = id+    onlyInstalled = fromFlag (listInstalled listFlags)+    simpleOutput  = fromFlag (listSimpleOutput listFlags)++-- | 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              :: String,+    installedVersions :: [Version],+    availableVersions :: [Version],+    homepage          :: String,+    category          :: String,+    synopsis          :: String,+    license           :: License+  }++showPackageInfo :: PackageDisplayInfo -> String+showPackageInfo pkg =+  renderStyle (style {lineLength = 80, ribbonsPerLine = 1}) $+     text " *" <+> text (name pkg)+     $+$+     (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))+     ])+     $+$ 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++-- | We get the 'PackageDisplayInfo' by combining the info for the installed+-- and available versions of a package.+--+-- * We're building info about a various versions of a single named package so+-- the input package info records are all supposed to refer to the same+-- package name.+--+mergePackageInfo :: [InstalledPackageInfo]+                 -> [AvailablePackage]+                 -> PackageDisplayInfo+mergePackageInfo installed available =+  assert (length installed + length available > 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+  }+  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))++-- | Rearrange installed and available packages into groups referring to the+-- same package by name. In the result pairs, the lists are guaranteed to not+-- both be empty.+--+mergePackages ::   [InstalledPackageInfo] -> [AvailablePackage]+              -> [([InstalledPackageInfo],   [AvailablePackage])]+mergePackages installed available =+    map collect+  $ mergeBy (\i a -> fst i `compare` fst a)+            (groupOn (pkgName . packageId) installed)+            (groupOn (pkgName . packageId) available)+  where+    collect (OnlyInLeft  (_,is)       ) = (is, [])+    collect (    InBoth  (_,is) (_,as)) = (is, as)+    collect (OnlyInRight        (_,as)) = ([], as)++groupOn :: Ord key => (a -> key) -> [a] -> [(key,[a])]+groupOn key = map (\xs -> (key (head xs), xs))+            . groupBy (equating key)+            . sortBy (comparing key)
+ Distribution/Client/Setup.hs view
@@ -0,0 +1,572 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Setup+-- Copyright   :  (c) David Himmelstrup 2005+-- License     :  BSD-like+--+-- Maintainer  :  lemmih@gmail.com+-- Stability   :  provisional+-- Portability :  portable+--+--+-----------------------------------------------------------------------------+module Distribution.Client.Setup+    ( globalCommand, GlobalFlags(..), globalRepos+    , configureCommand, Cabal.ConfigFlags(..), filterConfigureFlags, configPackageDB'+    , installCommand, InstallFlags(..), installOptions, defaultInstallFlags+    , listCommand, ListFlags(..)+    , updateCommand+    , upgradeCommand+    , infoCommand+    , fetchCommand+    , checkCommand+    , uploadCommand, UploadFlags(..)+    , reportCommand++    , parsePackageArgs+    --TODO: stop exporting these:+    , showRepo+    , parseRepo+    ) where++import Distribution.Client.Types+         ( Username(..), Password(..), Repo(..), RemoteRepo(..), LocalRepo(..) )++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 )+import Distribution.Simple.Setup+         ( Flag(..), toFlag, fromFlag, flagToList, flagToMaybe, fromFlagOrDefault+         , optionVerbosity, trueArg )+import Distribution.Simple.Compiler+         ( PackageDB(..) )+import Distribution.Version+         ( Version(Version), VersionRange(..) )+import Distribution.Package+         ( PackageIdentifier, packageName, packageVersion, Dependency(..) )+import Distribution.Text+         ( Text(parse), display )+import Distribution.ReadE+         ( readP_to_E, succeedReadE )+import qualified Distribution.Compat.ReadP as Parse+         ( ReadP, readP_to_S, char, munch1, pfail, (+++) )+import Distribution.Verbosity+         ( Verbosity, normal )++import Data.Char+         ( isSpace, isAlphaNum )+import Data.Maybe+         ( listToMaybe, maybeToList )+import Data.Monoid+         ( Monoid(..) )+import Control.Monad+         ( liftM )+import System.FilePath+         ( (</>) )+import Network.URI+         ( parseAbsoluteURI, uriToString )++-- ------------------------------------------------------------+-- * Global flags+-- ------------------------------------------------------------++-- | Flags that apply at the top level, not to any sub-command.+data GlobalFlags = GlobalFlags {+    globalVersion        :: Flag Bool,+    globalNumericVersion :: Flag Bool,+    globalConfigFile     :: Flag FilePath,+    globalRemoteRepos    :: [RemoteRepo],     -- ^Available Hackage servers.+    globalCacheDir       :: Flag FilePath,+    globalLocalRepos     :: [FilePath]+  }++defaultGlobalFlags :: GlobalFlags+defaultGlobalFlags  = GlobalFlags {+    globalVersion        = Flag False,+    globalNumericVersion = Flag False,+    globalConfigFile     = mempty,+    globalRemoteRepos    = [],+    globalCacheDir       = mempty,+    globalLocalRepos     = mempty+  }++globalCommand :: CommandUI GlobalFlags+globalCommand = CommandUI {+    commandName         = "",+    commandSynopsis     = "",+    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        = \_ -> [],+    commandDefaultFlags = defaultGlobalFlags,+    commandOptions      = \showOrParseArgs ->+      (case showOrParseArgs of ShowArgs -> take 2; ParseArgs -> id)+      [option ['V'] ["version"]+         "Print version information"+         globalVersion (\v flags -> flags { globalVersion = v })+         trueArg++      ,option [] ["numeric-version"]+         "Print just the version number"+         globalNumericVersion (\v flags -> flags { globalNumericVersion = v })+         trueArg++      ,option [] ["config-file"]+         "Set an alternate location for the config file"+         globalConfigFile (\v flags -> flags { globalConfigFile = v })+         (reqArgFlag "FILE")++      ,option [] ["remote-repo"]+         "The name and url for a remote repository"+         globalRemoteRepos (\v flags -> flags { globalRemoteRepos = v })+         (reqArg' "NAME:URL" (maybeToList . readRepo) (map showRepo))++      ,option [] ["remote-repo-cache"]+         "The location where downloads from all remote repos are cached"+         globalCacheDir (\v flags -> flags { globalCacheDir = v })+         (reqArgFlag "DIR")++      ,option [] ["local-repo"]+         "The location of a local repository"+         globalLocalRepos (\v flags -> flags { globalLocalRepos = v })+         (reqArg' "DIR" (\x -> [x]) id)+      ]+  }++instance Monoid GlobalFlags where+  mempty = GlobalFlags {+    globalVersion        = mempty,+    globalNumericVersion = mempty,+    globalConfigFile     = mempty,+    globalRemoteRepos    = mempty,+    globalCacheDir       = mempty,+    globalLocalRepos     = mempty+  }+  mappend a b = GlobalFlags {+    globalVersion        = combine globalVersion,+    globalNumericVersion = combine globalNumericVersion,+    globalConfigFile     = combine globalConfigFile,+    globalRemoteRepos    = combine globalRemoteRepos,+    globalCacheDir       = combine globalCacheDir,+    globalLocalRepos     = combine globalLocalRepos+  }+    where combine field = field a `mappend` field b++globalRepos :: GlobalFlags -> [Repo]+globalRepos globalFlags = remoteRepos ++ localRepos+  where+    remoteRepos =+      [ Repo (Left remote) cacheDir+      | remote <- globalRemoteRepos globalFlags+      , let cacheDir = fromFlag (globalCacheDir globalFlags)+                   </> remoteRepoName remote ]+    localRepos =+      [ Repo (Right LocalRepo) local+      | local <- globalLocalRepos globalFlags ]++-- ------------------------------------------------------------+-- * Config flags+-- ------------------------------------------------------------++configureCommand :: CommandUI Cabal.ConfigFlags+configureCommand = (Cabal.configureCommand defaultProgramConfiguration) {+    commandDefaultFlags = mempty+  }++configPackageDB' :: Cabal.ConfigFlags -> PackageDB+configPackageDB' config =+  fromFlagOrDefault defaultDB (Cabal.configPackageDB config)+  where+    defaultDB = case Cabal.configUserInstall config of+      NoFlag     -> UserPackageDB+      Flag True  -> UserPackageDB+      Flag False -> GlobalPackageDB++filterConfigureFlags :: Cabal.ConfigFlags -> Version -> Cabal.ConfigFlags+filterConfigureFlags flags cabalLibVersion+  | cabalLibVersion >= Version [1,3,10] [] = flags+    -- older Cabal does not grok the constraints flag:+  | otherwise = flags { Cabal.configConstraints = [] }++-- ------------------------------------------------------------+-- * Other commands+-- ------------------------------------------------------------++fetchCommand :: CommandUI (Flag Verbosity)+fetchCommand = CommandUI {+    commandName         = "fetch",+    commandSynopsis     = "Downloads packages for later installation or study.",+    commandDescription  = Nothing,+    commandUsage        = usagePackages "fetch",+    commandDefaultFlags = toFlag normal,+    commandOptions      = \_ -> [optionVerbosity id const]+  }++updateCommand  :: CommandUI (Flag Verbosity)+updateCommand = CommandUI {+    commandName         = "update",+    commandSynopsis     = "Updates list of known packages",+    commandDescription  = Nothing,+    commandUsage        = usagePackages "update",+    commandDefaultFlags = toFlag normal,+    commandOptions      = \_ -> [optionVerbosity id const]+  }++upgradeCommand  :: CommandUI (Cabal.ConfigFlags, InstallFlags)+upgradeCommand = configureCommand {+    commandName         = "upgrade",+    commandSynopsis     = "Upgrades installed packages to the latest available version",+    commandDescription  = Nothing,+    commandUsage        = usagePackages "upgrade",+    commandDefaultFlags = (mempty, defaultInstallFlags),+    commandOptions      = commandOptions installCommand+  }++{-+cleanCommand  :: CommandUI ()+cleanCommand = makeCommand name shortDesc longDesc emptyFlags options+  where+    name       = "clean"+    shortDesc  = "Removes downloaded files"+    longDesc   = Nothing+    emptyFlags = ()+    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",+    commandSynopsis     = "Check the package for common mistakes",+    commandDescription  = Nothing,+    commandUsage        = \pname -> "Usage: " ++ pname ++ " check\n",+    commandDefaultFlags = toFlag normal,+    commandOptions      = mempty+  }++reportCommand :: CommandUI (Flag Verbosity)+reportCommand = CommandUI {+    commandName         = "report",+    commandSynopsis     = "Upload build reports to a remote server.",+    commandDescription  = Nothing,+    commandUsage        = \pname -> "Usage: " ++ pname ++ " report\n",+    commandDefaultFlags = toFlag normal,+    commandOptions      = \_ -> [optionVerbosity id const]+  }++-- ------------------------------------------------------------+-- * List flags+-- ------------------------------------------------------------++data ListFlags = ListFlags {+    listInstalled :: Flag Bool,+    listSimpleOutput :: Flag Bool,+    listVerbosity :: Flag Verbosity+  }++defaultListFlags :: ListFlags+defaultListFlags = ListFlags {+    listInstalled = Flag False,+    listSimpleOutput = Flag False,+    listVerbosity = toFlag normal+  }++listCommand  :: CommandUI ListFlags+listCommand = CommandUI {+    commandName         = "list",+    commandSynopsis     = "List available packages on the server (cached).",+    commandDescription  = Nothing,+    commandUsage        = usagePackages "list",+    commandDefaultFlags = defaultListFlags,+    commandOptions      = \_ -> [+        optionVerbosity listVerbosity (\v flags -> flags { listVerbosity = v })++        , option [] ["installed"]+            "Only print installed packages"+            listInstalled (\v flags -> flags { listInstalled = v })+            trueArg++        , option [] ["simple-output"]+            "Print in a easy-to-parse format"+            listSimpleOutput (\v flags -> flags { listSimpleOutput = v })+            trueArg++        ]+  }++instance Monoid ListFlags where+  mempty = defaultListFlags+  mappend a b = ListFlags {+    listInstalled = combine listInstalled,+    listSimpleOutput = combine listSimpleOutput,+    listVerbosity = combine listVerbosity+  }+    where combine field = field a `mappend` field b++-- ------------------------------------------------------------+-- * Install flags+-- ------------------------------------------------------------++-- | Install takes the same flags as configure along with a few extras.+--+data InstallFlags = InstallFlags {+    installDocumentation:: Flag Bool,+    installDryRun       :: Flag Bool,+    installReinstall    :: Flag Bool,+    installOnly         :: Flag Bool,+    installRootCmd      :: Flag String,+    installCabalVersion :: Flag Version,+    installLogFile      :: Flag FilePath,+    installBuildReports :: Flag Bool,+    installSymlinkBinDir:: Flag FilePath+  }++defaultInstallFlags :: InstallFlags+defaultInstallFlags = InstallFlags {+    installDocumentation= Flag False,+    installDryRun       = Flag False,+    installReinstall    = Flag False,+    installOnly         = Flag False,+    installRootCmd      = mempty,+    installCabalVersion = mempty,+    installLogFile      = mempty,+    installBuildReports = Flag False,+    installSymlinkBinDir= mempty+  }++installCommand :: CommandUI (Cabal.ConfigFlags, InstallFlags)+installCommand = configureCommand {+  commandName         = "install",+  commandSynopsis     = "Installs a list of packages.",+  commandUsage        = usagePackages "install",+  commandDefaultFlags = (mempty, mempty),+  commandOptions      = \showOrParseArgs ->+    liftOptionsFst (commandOptions configureCommand showOrParseArgs) +++    liftOptionsSnd (installOptions showOrParseArgs)+  }++installOptions ::  ShowOrParseArgs -> [OptionField InstallFlags]+installOptions showOrParseArgs =+      [ option "" ["documentation"]+          "building of documentation"+          installDocumentation (\v flags -> flags { installDocumentation = v })+          (boolOpt [] [])++      , option [] ["dry-run"]+          "Do not install anything, only print what would be installed."+          installDryRun (\v flags -> flags { installDryRun = v })+          trueArg++      , option [] ["reinstall"]+          "Install even if it means installing the same version again."+          installReinstall (\v flags -> flags { installReinstall = v })+          trueArg++      , option [] ["root-cmd"]+          "Command used to gain root privileges, when installing with --global."+          installRootCmd (\v flags -> flags { installRootCmd = v })+          (reqArg' "COMMAND" toFlag flagToList)++      , option [] ["symlink-bindir"]+          "Add symlinks to installed executables into this directory."+           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 [] ["log-builds"]+          "Log all builds to file (name template can use $pkgid, $compiler, $os, $arch)"+          installLogFile (\v flags -> flags { installLogFile = v })+          (reqArg' "FILE" toFlag flagToList)++      , option [] ["build-reports"]+          "Generate detailed build reports. (overrides --log-builds)"+          installBuildReports (\v flags -> flags { installBuildReports = v })+          trueArg++      ] ++ case showOrParseArgs of      -- TODO: remove when "cabal install" avoids+          ParseArgs ->+            option [] ["only"]+              "Only installs the package in the current directory."+              installOnly (\v flags -> flags { installOnly = v })+              trueArg+             : []+          _ -> []++instance Monoid InstallFlags where+  mempty = InstallFlags {+    installDocumentation= mempty,+    installDryRun       = mempty,+    installReinstall    = mempty,+    installOnly         = mempty,+    installRootCmd      = mempty,+    installCabalVersion = mempty,+    installLogFile      = mempty,+    installBuildReports = mempty,+    installSymlinkBinDir= mempty+  }+  mappend a b = InstallFlags {+    installDocumentation= combine installDocumentation,+    installDryRun       = combine installDryRun,+    installReinstall    = combine installReinstall,+    installOnly         = combine installOnly,+    installRootCmd      = combine installRootCmd,+    installCabalVersion = combine installCabalVersion,+    installLogFile      = combine installLogFile,+    installBuildReports = combine installBuildReports,+    installSymlinkBinDir= combine installSymlinkBinDir+  }+    where combine field = field a `mappend` field b++-- ------------------------------------------------------------+-- * Upload flags+-- ------------------------------------------------------------++data UploadFlags = UploadFlags {+    uploadCheck     :: Flag Bool,+    uploadUsername  :: Flag Username,+    uploadPassword  :: Flag Password,+    uploadVerbosity :: Flag Verbosity+  }++defaultUploadFlags :: UploadFlags+defaultUploadFlags = UploadFlags {+    uploadCheck     = toFlag False,+    uploadUsername  = mempty,+    uploadPassword  = mempty,+    uploadVerbosity = toFlag normal+  }++uploadCommand :: CommandUI UploadFlags+uploadCommand = CommandUI {+    commandName         = "upload",+    commandSynopsis     = "Uploads source packages to Hackage",+    commandDescription  = Just $ \_ ->+         "You can store your Hackage login in the ~/.cabal/config file\n",+    commandUsage        = \pname ->+         "Usage: " ++ pname ++ " upload [FLAGS] [TARFILES]\n\n"+      ++ "Flags for upload:",+    commandDefaultFlags = defaultUploadFlags,+    commandOptions      = \_ ->+      [optionVerbosity uploadVerbosity (\v flags -> flags { uploadVerbosity = v })++      ,option ['c'] ["check"]+         "Do not upload, just do QA checks."+        uploadCheck (\v flags -> flags { uploadCheck = v })+        trueArg++      ,option ['u'] ["username"]+        "Hackage username."+        uploadUsername (\v flags -> flags { uploadUsername = v })+        (reqArg' "USERNAME" (toFlag . Username)+                            (flagToList . fmap unUsername))++      ,option ['p'] ["password"]+        "Hackage password."+        uploadPassword (\v flags -> flags { uploadPassword = v })+        (reqArg' "PASSWORD" (toFlag . Password)+                            (flagToList . fmap unPassword))+      ]+  }++instance Monoid UploadFlags where+  mempty = UploadFlags {+    uploadCheck     = mempty,+    uploadUsername  = mempty,+    uploadPassword  = mempty,+    uploadVerbosity = mempty+  }+  mappend a b = UploadFlags {+    uploadCheck     = combine uploadCheck,+    uploadUsername  = combine uploadUsername,+    uploadPassword  = combine uploadPassword,+    uploadVerbosity = combine uploadVerbosity+  }+    where combine field = field a `mappend` field b++-- ------------------------------------------------------------+-- * GetOpt Utils+-- ------------------------------------------------------------++boolOpt :: SFlags -> SFlags -> MkOptDescr (a -> Flag Bool) (Flag Bool -> a -> a) a+boolOpt  = Command.boolOpt  flagToMaybe Flag++reqArgFlag :: ArgPlaceHolder -> SFlags -> LFlags -> Description ->+              (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)))++usagePackages :: String -> String -> String+usagePackages name pname =+     "Usage: " ++ pname ++ " " ++ name ++ " [FLAGS]\n"+  ++ "   or: " ++ pname ++ " " ++ name ++ " [PACKAGES]\n\n"+  ++ "Flags for " ++ name ++ ":"++--TODO: do we want to allow per-package flags?+parsePackageArgs :: [String] -> Either String [Dependency]+parsePackageArgs = parsePkgArgs []+  where+    parsePkgArgs ds [] = Right (reverse ds)+    parsePkgArgs ds (arg:args) =+      case readPToMaybe parseDependencyOrPackageId arg of+        Just dep -> parsePkgArgs (dep:ds) args+        Nothing  -> Left ("Failed to parse package dependency: " ++ show arg)++readPToMaybe :: Parse.ReadP a a -> String -> Maybe a+readPToMaybe p str = listToMaybe [ r | (r,s) <- Parse.readP_to_S p str+                                     , all isSpace s ]++parseDependencyOrPackageId :: Parse.ReadP r Dependency+parseDependencyOrPackageId = parse Parse.+++ liftM pkgidToDependency parse+  where+    pkgidToDependency :: PackageIdentifier -> Dependency+    pkgidToDependency p = case packageVersion p of+      Version [] _ -> Dependency (packageName p) AnyVersion+      version      -> Dependency (packageName p) (ThisVersion version)++showRepo :: RemoteRepo -> String+showRepo repo = remoteRepoName repo ++ ":"+             ++ uriToString id (remoteRepoURI repo) []++readRepo :: String -> Maybe RemoteRepo+readRepo = readPToMaybe parseRepo++parseRepo :: Parse.ReadP r RemoteRepo+parseRepo = do+  name <- Parse.munch1 (\c -> isAlphaNum c || c `elem` "_-.")+  Parse.char ':'+  uriStr <- Parse.munch1 (\c -> isAlphaNum c || c `elem` "+-=._/*()@'$:;&!?~")+  uri <- maybe Parse.pfail return (parseAbsoluteURI uriStr)+  return $ RemoteRepo {+    remoteRepoName = name,+    remoteRepoURI  = uri+  }
+ Distribution/Client/SetupWrapper.hs view
@@ -0,0 +1,328 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.SetupWrapper+-- Copyright   :  (c) The University of Glasgow 2006,+--                    Duncan Coutts 2008+--+-- Maintainer  :  cabal-devel@haskell.org+-- Stability   :  alpha+-- Portability :  portable+--+-- An interface to building and installing Cabal packages.+-- If the @Built-Type@ field is specified as something other than+-- 'Custom', and the current version of Cabal is acceptable, this performs+-- setup actions directly.  Otherwise it builds the setup script and+-- runs it with the given arguments.++module Distribution.Client.SetupWrapper (+    setupWrapper,+    SetupScriptOptions(..),+    defaultSetupScriptOptions,+  ) where++import qualified Distribution.Make as Make+import qualified Distribution.Simple as Simple+import Distribution.Version+         ( Version(..), VersionRange(..), withinRange )+import Distribution.Package+         ( PackageIdentifier(..), Package(..), packageName, packageVersion+         , Dependency(..) )+import Distribution.PackageDescription+         ( GenericPackageDescription(packageDescription)+         , PackageDescription(..), BuildType(..), readPackageDescription )+import Distribution.InstalledPackageInfo+         ( InstalledPackageInfo )+import Distribution.Simple.Configure+         ( configCompiler, getInstalledPackages )+import Distribution.Simple.Compiler+         ( CompilerFlavor(GHC), Compiler, PackageDB(..) )+import Distribution.Simple.Program+         ( ProgramConfiguration, emptyProgramConfiguration+         , rawSystemProgramConf, ghcProgram )+import Distribution.Simple.BuildPaths+         ( defaultDistPref, exeExtension )+import Distribution.Simple.Command+         ( CommandUI(..), commandShowOptions )+import Distribution.Simple.GHC+         ( ghcVerbosityOptions )+import qualified Distribution.Simple.PackageIndex as PackageIndex+import Distribution.Simple.PackageIndex (PackageIndex)+import Distribution.Simple.Utils+         ( die, debug, info, cabalVersion, findPackageDesc, comparing+         , createDirectoryIfMissingVerbose, inDir )+import Distribution.Text+         ( display )+import Distribution.Verbosity+         ( Verbosity )++import System.Directory  ( doesFileExist, getModificationTime, getCurrentDirectory )+import System.FilePath   ( (</>), (<.>) )+import System.IO.Error   ( isDoesNotExistError )+import System.IO         ( Handle )+import System.Exit       ( ExitCode(..), exitWith )+import System.Process    ( runProcess, waitForProcess )+import Control.Monad     ( when, unless )+import Control.Exception ( evaluate )+import Data.List         ( maximumBy )+import Data.Maybe        ( fromMaybe, isJust )+import Data.Monoid       ( Monoid(mempty) )+import Data.Char         ( isSpace )++data SetupScriptOptions = SetupScriptOptions {+    useCabalVersion  :: VersionRange,+    useCompiler      :: Maybe Compiler,+    usePackageIndex  :: Maybe (PackageIndex InstalledPackageInfo),+    useProgramConfig :: ProgramConfiguration,+    useDistPref      :: FilePath,+    useLoggingHandle :: Maybe Handle,+    useWorkingDir    :: Maybe FilePath+  }++defaultSetupScriptOptions :: SetupScriptOptions+defaultSetupScriptOptions = SetupScriptOptions {+    useCabalVersion  = AnyVersion,+    useCompiler      = Nothing,+    usePackageIndex  = Nothing,+    useProgramConfig = emptyProgramConfiguration,+    useDistPref      = defaultDistPref,+    useLoggingHandle = Nothing,+    useWorkingDir    = Nothing+  }++setupWrapper :: Verbosity+             -> SetupScriptOptions+             -> Maybe PackageDescription+             -> CommandUI flags+             -> (Version -> flags)+             -> [String]+             -> IO ()+setupWrapper verbosity options mpkg cmd flags extraArgs = do+  pkg <- maybe getPkg return mpkg+  let setupMethod = determineSetupMethod options' buildType'+      options'    = options {+                      useCabalVersion = IntersectVersionRanges+                                          (useCabalVersion options)+                                          (descCabalVersion pkg)+                    }+      buildType'  = fromMaybe Custom (buildType pkg)+      mkArgs cabalLibVersion = commandName cmd+                             : commandShowOptions cmd (flags cabalLibVersion)+                            ++ extraArgs+  setupMethod verbosity options' (packageId pkg) buildType' mkArgs+  where+    getPkg = findPackageDesc (fromMaybe "." (useWorkingDir options))+         >>= readPackageDescription verbosity+         >>= return . packageDescription++-- | Decide if we're going to be able to do a direct internal call to the+-- entry point in the Cabal library or if we're going to have to compile+-- and execute an external Setup.hs script.+--+determineSetupMethod :: SetupScriptOptions -> BuildType -> SetupMethod+determineSetupMethod options buildType'+  | isJust (useLoggingHandle options)+ || buildType' == Custom      = externalSetupMethod+  | cabalVersion `withinRange`+      useCabalVersion options = internalSetupMethod+  | otherwise                 = externalSetupMethod++type SetupMethod = Verbosity+                -> SetupScriptOptions+                -> PackageIdentifier+                -> BuildType+                -> (Version -> [String]) -> IO ()++-- ------------------------------------------------------------+-- * Internal SetupMethod+-- ------------------------------------------------------------++internalSetupMethod :: SetupMethod+internalSetupMethod verbosity options _ bt mkargs = do+  let args = mkargs cabalVersion+  debug verbosity $ "Using internal setup method with build-type " ++ show bt+                 ++ " and args:\n  " ++ show args+  inDir (useWorkingDir options) $+    buildTypeAction bt args++buildTypeAction :: BuildType -> ([String] -> IO ())+buildTypeAction Simple    = Simple.defaultMainArgs+buildTypeAction Configure = Simple.defaultMainWithHooksArgs+                              Simple.autoconfUserHooks+buildTypeAction Make      = Make.defaultMainArgs+buildTypeAction Custom               = error "buildTypeAction Custom"+buildTypeAction (UnknownBuildType _) = error "buildTypeAction UnknownBuildType"++-- ------------------------------------------------------------+-- * External SetupMethod+-- ------------------------------------------------------------++externalSetupMethod :: SetupMethod+externalSetupMethod verbosity options pkg bt mkargs = do+  debug verbosity $ "Using external setup method with build-type " ++ show bt+  createDirectoryIfMissingVerbose verbosity True setupDir+  (cabalLibVersion, options') <- cabalLibVersionToUse+  debug verbosity $ "Using Cabal library version " ++ display cabalLibVersion+  setupHs <- updateSetupScript cabalLibVersion bt+  debug verbosity $ "Using " ++ setupHs ++ " as setup script."+  compileSetupExecutable options' cabalLibVersion setupHs+  invokeSetupScript (mkargs cabalLibVersion)++  where+  workingDir       = fromMaybe "" (useWorkingDir options)+  setupDir         = workingDir </> useDistPref options </> "setup"+  setupVersionFile = setupDir </> "setup" <.> "version"+  setupProgFile    = setupDir </> "setup" <.> exeExtension++  cabalLibVersionToUse :: IO (Version, SetupScriptOptions)+  cabalLibVersionToUse = do+    savedVersion <- savedCabalVersion+    case savedVersion of+      Just version | version `withinRange` useCabalVersion options+        -> return (version, options)+      _ -> do (comp, conf, options') <- configureCompiler options+              version <- installedCabalVersion options comp conf+              writeFile setupVersionFile (show version ++ "\n")+              return (version, options')++  savedCabalVersion = do+    versionString <- readFile setupVersionFile `catch` \_ -> return ""+    case reads versionString of+      [(version,s)] | all isSpace s -> return (Just version)+      _                             -> return Nothing++  installedCabalVersion :: SetupScriptOptions -> Compiler+                        -> ProgramConfiguration -> IO Version+  installedCabalVersion _ _ _ | packageName pkg == "Cabal" =+    return (packageVersion pkg)+  installedCabalVersion options' comp conf = do+    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++    let cabalDep = Dependency "Cabal" (useCabalVersion options)+    case PackageIndex.lookupDependency index cabalDep of+      []   -> die $ "The package requires Cabal library version "+                 ++ display (useCabalVersion options)+                 ++ " but no suitable version is installed."+      pkgs -> return $ bestVersion (map packageVersion pkgs)+    where+      bestVersion          = maximumBy (comparing preference)+      preference version   = (sameVersion, sameMajorVersion+                             ,stableVersion, latestVersion)+        where+          sameVersion      = version == cabalVersion+          sameMajorVersion = majorVersion version == majorVersion cabalVersion+          majorVersion     = take 2 . versionBranch+          stableVersion    = case versionBranch version of+                               (_:x:_) -> even x+                               _       -> False+          latestVersion    = version++  configureCompiler :: SetupScriptOptions+                    -> IO (Compiler, ProgramConfiguration, SetupScriptOptions)+  configureCompiler options' = do+    (comp, conf) <- case useCompiler options' of+      Just comp -> return (comp, useProgramConfig options')+      Nothing   -> configCompiler (Just GHC) Nothing Nothing+                     (useProgramConfig options') verbosity+    return (comp, conf, options' { useCompiler = Just comp,+                                   useProgramConfig = conf })++  -- | Decide which Setup.hs script to use, creating it if necessary.+  --+  updateSetupScript :: Version -> BuildType -> IO FilePath+  updateSetupScript _ Custom = do+    useHs  <- doesFileExist setupHs+    useLhs <- doesFileExist setupLhs+    unless (useHs || useLhs) $ die+      "Using 'build-type: Custom' but there is no Setup.hs or Setup.lhs script."+    return (if useHs then setupHs else setupLhs)+    where+      setupHs  = workingDir </> "Setup.hs"+      setupLhs = workingDir </> "Setup.lhs"++  updateSetupScript cabalLibVersion _ = do+    rewriteFile setupHs (buildTypeScript cabalLibVersion)+    return setupHs+    where+      setupHs  = setupDir </> "setup.hs"++  buildTypeScript :: Version -> String+  buildTypeScript cabalLibVersion = case bt of+    Simple    -> "import Distribution.Simple; main = defaultMain\n"+    Configure -> "import Distribution.Simple; main = defaultMainWithHooks "+              ++ if cabalLibVersion >= Version [1,3,10] []+                   then "autoconfUserHooks\n"+                   else "defaultUserHooks\n"+    Make      -> "import Distribution.Make; main = defaultMain\n"+    Custom             -> error "buildTypeScript Custom"+    UnknownBuildType _ -> error "buildTypeScript UnknownBuildType"++  -- | If the Setup.hs is out of date wrt the executable then recompile it.+  -- Currently this is GHC only. It should really be generalised.+  --+  compileSetupExecutable :: SetupScriptOptions -> Version -> FilePath -> IO ()+  compileSetupExecutable options' cabalLibVersion setupHsFile = do+    setupHsNewer      <- setupHsFile      `moreRecentFile` setupProgFile+    cabalVersionNewer <- setupVersionFile `moreRecentFile` setupProgFile+    let outOfDate = setupHsNewer || cabalVersionNewer+    when outOfDate $ do+      debug verbosity "Setup script is out of date, compiling..."+      (_, conf, _) <- configureCompiler options'+      rawSystemProgramConf verbosity ghcProgram conf $+          ghcVerbosityOptions verbosity+       ++ ["--make", setupHsFile, "-o", setupProgFile+          ,"-odir", setupDir, "-hidir", setupDir]+       ++ if packageName pkg == "Cabal"+            then ["-i", "-i."]+            else ["-i", "-package", display cabalPkgid ]+    where cabalPkgid = PackageIdentifier "Cabal" cabalLibVersion++  invokeSetupScript :: [String] -> IO ()+  invokeSetupScript args = do+    info verbosity $ unwords (setupProgFile : args)+    case useLoggingHandle options of+      Nothing        -> return ()+      Just logHandle -> info verbosity $ "Redirecting build log to "+                                      ++ show logHandle+    currentDir <- getCurrentDirectory+    process <- runProcess (currentDir </> setupProgFile) args+                 (useWorkingDir options) Nothing+                 Nothing (useLoggingHandle options) (useLoggingHandle options)+    exitCode <- waitForProcess process+    unless (exitCode == ExitSuccess) $ exitWith exitCode++-- ------------------------------------------------------------+-- * Utils+-- ------------------------------------------------------------++-- | Compare the modification times of two files to see if the first is newer+-- than the second. The first file must exist but the second need not.+-- The expected use case is when the second file is generated using the first.+-- In this use case, if the result is True then the second file is out of date.+--+moreRecentFile :: FilePath -> FilePath -> IO Bool+moreRecentFile a b = do+  exists <- doesFileExist b+  if not exists+    then return True+    else do tb <- getModificationTime b+            ta <- getModificationTime a+            return (ta > tb)++-- | Write a file but only if it would have new content. If we would be writing+-- the same as the existing content then leave the file as is so that we do not+-- update the file's modification time.+--+rewriteFile :: FilePath -> String -> IO ()+rewriteFile path newContent =+  flip catch mightNotExist $ do+    existingContent <- readFile path+    evaluate (length existingContent)+    unless (existingContent == newContent) $+      writeFile path newContent+  where+    mightNotExist e | isDoesNotExistError e = writeFile path newContent+                    | otherwise             = ioError e
+ Distribution/Client/SrcDist.hs view
@@ -0,0 +1,80 @@+-- Implements the \"@.\/cabal sdist@\" command, which creates a source+-- distribution for this package.  That is, packs up the source code+-- into a tarball, making use of the corresponding Cabal module.+module Distribution.Client.SrcDist (+         sdist+  )  where+import Distribution.Simple.SrcDist+         ( printPackageProblems, prepareTree, prepareSnapshotTree )+import Distribution.Client.Tar (createTarGzFile)++import Distribution.Package+         ( Package(..) )+import Distribution.PackageDescription+         ( PackageDescription, readPackageDescription )+import Distribution.Simple.Utils+         ( withTempDirectory , defaultPackageDesc+         , die, warn, notice, setupMessage )+import Distribution.Simple.Setup (SDistFlags(..), fromFlag)+import Distribution.Verbosity (Verbosity)+import Distribution.Simple.PreProcess (knownSuffixHandlers)+import Distribution.Simple.BuildPaths ( srcPref)+import Distribution.Simple.Configure(maybeGetPersistBuildConfig)+import Distribution.PackageDescription.Configuration ( flattenPackageDescription )+import Distribution.Text+         ( display )++import System.Time (getClockTime, toCalendarTime)+import System.FilePath ((</>), (<.>))+import System.Directory (doesDirectoryExist)+import Control.Monad (when)+import Data.Maybe (isNothing)++-- |Create a source distribution.+sdist :: SDistFlags -> IO ()+sdist flags = do+  pkg <- return . flattenPackageDescription+     =<< readPackageDescription verbosity+     =<< defaultPackageDesc verbosity+  mb_lbi <- maybeGetPersistBuildConfig distPref+  let tmpDir = 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++    setupMessage verbosity "Building source dist for" (packageId pkg)+    if snapshot+      then getClockTime >>= toCalendarTime+       >>= prepareSnapshotTree verbosity pkg mb_lbi+                               distPref tmpDir knownSuffixHandlers+      else prepareTree         verbosity pkg mb_lbi+                               distPref tmpDir knownSuffixHandlers+    targzFile <- createArchive verbosity pkg tmpDir distPref+    notice verbosity $ "Source tarball created: " ++ targzFile++  where+    verbosity = fromFlag (sDistVerbosity flags)+    snapshot  = fromFlag (sDistSnapshot flags)+    distPref  = fromFlag (sDistDistPref flags)++-- |Create an archive from a tree of source files, and clean up the tree.+createArchive :: Verbosity+              -> PackageDescription+              -> FilePath+              -> FilePath+              -> IO FilePath+createArchive _verbosity pkg tmpDir targetPref = do+  let tarBallName     = display (packageId pkg)+      tarBallFilePath = targetPref </> tarBallName <.> "tar.gz"+  createTarGzFile tarBallFilePath tmpDir tarBallName+  return tarBallFilePath
+ Distribution/Client/Tar.hs view
@@ -0,0 +1,721 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Tar+-- Copyright   :  (c) 2007 Bjorn Bringert,+--                    2008 Andrea Vezzosi,+--                    2008 Duncan Coutts+-- License     :  BSD-like+--+-- Maintainer  :  duncan@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- TAR archive reading and writing+--+-----------------------------------------------------------------------------+module Distribution.Client.Tar (+  -- * High level all in one operations on files+  createTarGzFile,+  extractTarGzFile,++  -- * Reading and writing the tar format+  read,+  write,++  -- * Packing and unpacking files to\/from a tar archive+  pack,+  unpack,++  -- * Tar archive 'Entry'+  Entry(..), fileName,+  ExtendedHeader(..),+  FileType(..),+  UserId,+  GroupId,+  EpochTime,+  DevMajor,+  DevMinor,+  FileSize,++  -- ** Constructing entries+  emptyEntry,+  simpleFileEntry,+  simpleDirectoryEntry,++  -- ** 'TarPath's+  TarPath,+  toTarPath,+  fromTarPath,++  -- * Sequence of 'Entry' records with failures+  Entries(..),+  foldEntries,+  unfoldEntries,+  mapEntries,++  -- * Sanity checking tar contents+  checkEntryNames+  ) where++import Data.Char   (ord)+import Data.Int    (Int64)+import Data.List   (foldl')+import Data.Monoid (Monoid(..))+import Numeric     (readOct, showOct)++import qualified Data.ByteString.Lazy as BS+import qualified Data.ByteString.Lazy.Char8 as BS.Char8+import Data.ByteString.Lazy (ByteString)+import qualified Codec.Compression.GZip as GZip++import System.FilePath+         ( (</>) )+import qualified System.FilePath as FilePath.Native+         ( (</>), joinPath, splitDirectories, takeDirectory+         , isAbsolute, isValid, makeRelative )+import qualified System.FilePath.Posix as FilePath.Posix+         ( joinPath, pathSeparator, splitPath, splitDirectories )+import System.Directory+         ( getDirectoryContents, doesDirectoryExist+         , getModificationTime,  createDirectoryIfMissing, copyFile+         , Permissions(..), getPermissions )+import System.Posix.Types+         ( FileMode )+import System.Time+         ( ClockTime(..) )+import System.IO+         ( IOMode(ReadMode), openBinaryFile, hFileSize )+import System.IO.Unsafe (unsafeInterleaveIO)++import Distribution.Client.Utils+         ( writeFileAtomic )++import Prelude hiding (read)++--+-- * High level operations+--++createTarGzFile :: FilePath  -- ^ Full Tarball path+                -> FilePath  -- ^ Base directory+                -> FilePath  -- ^ Directory to archive, relative to base dir+                -> IO ()+createTarGzFile tar base dir =+  writeFileAtomic tar . GZip.compress . write =<< pack base dir++extractTarGzFile :: FilePath -- ^ Destination directory+                 -> FilePath -- ^ Tarball+                 -> IO ()+extractTarGzFile dir tar =+  unpack dir . checkEntryNames . read . GZip.decompress =<< BS.readFile tar++--+-- * Entry type+--++type UserId    = Int+type GroupId   = Int+type EpochTime = Int -- ^ The number of seconds since the UNIX epoch+type DevMajor  = Int+type DevMinor  = Int+type FileSize  = Int64++-- | TAR archive entry+data Entry = Entry {++    -- | Path of the file or directory. The path separator should be @/@ for+    -- portable TAR archives.+    filePath :: TarPath,++    -- | UNIX file mode.+    fileMode :: FileMode,++    -- | Numeric owner user id. Should be set to @0@ if unknown.+    ownerId :: UserId,++    -- | Numeric owner group id. Should be set to @0@ if unknown.+    groupId :: GroupId,++    -- | File size in bytes. Should be 0 for entries other than normal files.+    fileSize :: FileSize,++    -- | Last modification time.+    modTime :: EpochTime,++    -- | Type of this entry.+    fileType :: FileType,++    -- | If the entry is a hard link or a symbolic link, this is the path of+    -- the link target. For all other entry types this should be @\"\"@.+    linkTarget :: FilePath,++    -- | The remaining meta-data is in the V7, ustar/posix or gnu formats+    -- For V7 there is no extended info at all and for posix/ustar the+    -- information is the same though the kind affects the way the information+    -- is encoded.+    headerExt :: ExtendedHeader,++    -- | Entry contents. For entries other than normal+    -- files, this should be an empty string.+    fileContent :: ByteString+  }++fileName :: Entry -> FilePath+fileName = fromTarPath . filePath++data ExtendedHeader+   = V7+   | USTAR {+    -- | The owner user name. Should be set to @\"\"@ if unknown.+    ownerName :: String,++    -- | The owner group name. Should be set to @\"\"@ if unknown.+    groupName :: String,++    -- | For character and block device entries, this is the+    -- major number of the device. For all other entry types, it+    -- should be set to @0@.+    deviceMajor :: DevMajor,++    -- | For character and block device entries, this is the+    -- minor number of the device. For all other entry types, it+    -- should be set to @0@.+    deviceMinor :: DevMinor+   }+   | GNU {+    -- | The owner user name. Should be set to @\"\"@ if unknown.+    ownerName :: String,++    -- | The owner group name. Should be set to @\"\"@ if unknown.+    groupName :: String,++    -- | For character and block device entries, this is the+    -- major number of the device. For all other entry types, it+    -- should be set to @0@.+    deviceMajor :: DevMajor,++    -- | For character and block device entries, this is the+    -- minor number of the device. For all other entry types, it+    -- should be set to @0@.+    deviceMinor :: DevMinor+   }++-- | TAR archive entry types.+data FileType = NormalFile+              | HardLink+              | SymbolicLink+              | CharacterDevice+              | BlockDevice+              | Directory+              | FIFO+              | ExtendedHeader+              | GlobalHeader+              | Custom Char   -- 'A' .. 'Z'+              | Reserved Char -- other / reserved / unknown+  deriving (Eq, Show)++toFileTypeCode :: FileType -> Char+toFileTypeCode NormalFile      = '0'+toFileTypeCode HardLink        = '1'+toFileTypeCode SymbolicLink    = '2'+toFileTypeCode CharacterDevice = '3'+toFileTypeCode BlockDevice     = '4'+toFileTypeCode Directory       = '5'+toFileTypeCode FIFO            = '6'+toFileTypeCode ExtendedHeader  = 'x'+toFileTypeCode GlobalHeader    = 'g'+toFileTypeCode (Custom   c)    = c+toFileTypeCode (Reserved c)    = c++fromFileTypeCode :: Char -> FileType+fromFileTypeCode '0'  = NormalFile+fromFileTypeCode '\0' = NormalFile+fromFileTypeCode '1'  = HardLink+fromFileTypeCode '2'  = SymbolicLink+fromFileTypeCode '3'  = CharacterDevice+fromFileTypeCode '4'  = BlockDevice+fromFileTypeCode '5'  = Directory+fromFileTypeCode '6'  = FIFO+fromFileTypeCode '7'  = NormalFile+fromFileTypeCode 'x'  = ExtendedHeader+fromFileTypeCode 'g'  = GlobalHeader+fromFileTypeCode  c   | c >= 'A' && c <= 'Z'+                      = Custom c+fromFileTypeCode  c   = Reserved c++emptyEntry :: FileType -> TarPath -> Entry+emptyEntry ftype tarpath = Entry {+    filePath = tarpath,+    fileMode = case ftype of+                 Directory -> 0o0755  -- rwxr-xr-x for directories+                 _         -> 0o0644, -- rw-r--r-- for normal files+    ownerId  = 0,+    groupId  = 0,+    fileSize = 0,+    modTime  = 0,+    fileType = ftype,+    linkTarget = "",+    headerExt  = USTAR {+      ownerName = "",+      groupName = "",+      deviceMajor = 0,+      deviceMinor = 0+    },+    fileContent = BS.empty+  }++simpleFileEntry :: TarPath -> ByteString -> Entry+simpleFileEntry name content = (emptyEntry NormalFile name) {+    fileSize = BS.length content,+    fileContent = content+  }++simpleDirectoryEntry :: TarPath -> Entry+simpleDirectoryEntry name = emptyEntry Directory name++--+-- * Tar paths+--++-- | The classic tar format allowed just 100 charcters for the file name. The+-- USTAR format extended this with an extra 155 characters, however it uses a+-- complex method of splitting the name between the two sections.+--+-- Instead of just putting any overflow into the extended area, it uses the+-- extended area as a prefix. The agrevating insane bit however is that the+-- prefix (if any) must only contain a directory prefix. That is the split+-- between the two areas must be on a directory separator boundary. So there is+-- no simple calculation to work out if a file name is too long. Instead we+-- have to try to find a valid split that makes the name fit in the two areas.+--+-- The rationale presumably was to make it a bit more compatible with tar+-- programs that only understand the classic format. A classic tar would be+-- able to extract the file name and possibly some dir prefix, but not the+-- full dir prefix. So the files would end up in the wrong place, but that's+-- probably better than ending up with the wrong names too.+--+-- So it's understandable but rather annoying.+--+-- * Tar paths use posix format (ie @\'/\'@ directory separators), irrespective+--   of the local path conventions.+--+-- * The directory separator between the prefix and name is /not/ stored.+--+data TarPath = TarPath FilePath -- path name, 100 characters max.+                       FilePath -- path prefix, 155 characters max.++-- | Convert a 'TarPath' to a native 'FilePath'.+--+-- The native 'FilePath' will use the native directory separator but it is not+-- otherwise checked for validity or sanity. In particular:+--+-- * The tar path may be invalid as a native path, eg the filename @\"nul\"@ is+--   not valid on Windows.+-- * The tar path may be an absolute path or may contain @\"..\"@ components.+--   For security reasons this should not usually be allowed, but it is your+--   responsibility to check for these conditions.+--+fromTarPath :: TarPath -> FilePath+fromTarPath (TarPath name prefix) =+  FilePath.Native.joinPath $ FilePath.Posix.splitDirectories prefix+                          ++ FilePath.Posix.splitDirectories name++-- | Convert a native 'FilePath' to a 'TarPath'. The 'FileType' is needed+-- because for directories a 'TarPath' uses a trailing @\/@.+--+-- The conversion may fail if the 'FilePath' is too long. See 'TarPath' for a+-- description of the problem with splitting long 'FilePath's.+--+toTarPath :: FileType -> FilePath -> Either String TarPath+toTarPath ftype = splitLongPath+                . addTrailingSep ftype+                . FilePath.Posix.joinPath+                . FilePath.Native.splitDirectories+  where+    addTrailingSep Directory path = path ++ [FilePath.Posix.pathSeparator]+    addTrailingSep _         path = path++-- | Takes a sanitized path, split on directory separators and tries to pack it+-- into the 155 + 100 tar file name format.+--+-- The stragey is this: take the name-directory components in reverse order+-- and try to fit as many components into the 100 long name area as possible.+-- If all the remaining components fit in the 155 name area then we win.+--+splitLongPath :: FilePath -> Either String TarPath+splitLongPath path =+  case packName nameMax (reverse (FilePath.Posix.splitPath path)) of+    Left err                 -> Left err+    Right (name, [])         -> Right (TarPath name "")+    Right (name, first:rest) -> case packName prefixMax remainder of+      Left err               -> Left err+      Right (_     , (_:_))  -> Left "File name too long (cannot split)"+      Right (prefix, [])     -> Right (TarPath name prefix)+      where+        -- drop the '/' between the name and prefix:+        remainder = init first : rest++  where+    nameMax, prefixMax :: Int+    nameMax   = 100+    prefixMax = 155++    packName _      []     = Left "File name empty"+    packName maxLen (c:cs)+      | n > maxLen         = Left "File name too long"+      | otherwise          = Right (packName' maxLen n [c] cs)+      where n = length c++    packName' maxLen n ok (c:cs)+      | n' <= maxLen             = packName' maxLen n' (c:ok) cs+                                     where n' = n + length c+    packName' _      _ ok    cs  = (FilePath.Posix.joinPath ok, cs)++--+-- * Entries type+--++-- | A tar archive is a sequence of entries.+data Entries = Next Entry Entries+             | Done+             | Fail String++unfoldEntries :: (a -> Either String (Maybe (Entry, a))) -> a -> Entries+unfoldEntries f = unfold+  where+    unfold x = case f x of+      Left err             -> Fail err+      Right Nothing        -> Done+      Right (Just (e, x')) -> Next e (unfold x')++foldEntries :: (Entry -> a -> a) -> a -> (String -> a) -> Entries -> a+foldEntries next done fail' = fold+  where+    fold (Next e es) = next e (fold es)+    fold Done        = done+    fold (Fail err)  = fail' err++mapEntries :: (Entry -> Either String Entry) -> Entries -> Entries+mapEntries f =+  foldEntries (\entry rest -> either Fail (flip Next rest) (f entry)) Done Fail++--+-- * Checking+--++checkEntryNames :: Entries -> Entries+checkEntryNames =+  mapEntries (\entry -> maybe (Right entry) Left (checkEntryName entry))++checkEntryName :: Entry -> Maybe String+checkEntryName entry = case fileType entry of+    HardLink     -> check (fileName entry) `mappend` check (linkTarget entry)+    SymbolicLink -> check (fileName entry) `mappend` check (linkTarget entry)+    _            -> check (fileName entry)++  where+    check name+      | FilePath.Native.isAbsolute name+      = Just $ "Absolute file name in tar archive: " ++ show name+      | not (FilePath.Native.isValid name)+      = Just $ "Invalid file name in tar archive: " ++ show name+      | any (=="..") (FilePath.Native.splitDirectories name)+      = Just $ "Invalid file name in tar archive: " ++ show name+      | otherwise = Nothing++--+-- * Reading+--++read :: ByteString -> Entries+read = unfoldEntries getEntry++getEntry :: ByteString -> Either String (Maybe (Entry, ByteString))+getEntry bs+  | BS.length header < 512 = Left "Truncated TAR archive"+  | endBlock = Right Nothing --FIXME: force last two blocks to close fds!+  | not (correctChecksum header chksum)  = Left "TAR checksum error"+  | magic /= "ustar\NUL00"+ && magic /= "ustar  \NUL" = Left $ "TAR entry not ustar format: " ++ show magic+  | otherwise = Right (Just (entry, bs'''))+  where+   (header,bs')  = BS.splitAt 512 bs++   endBlock   = getByte 0 header == '\0'++   name       = getString   0 100 header+   mode       = getOct    100   8 header+   uid        = getOct    108   8 header+   gid        = getOct    116   8 header+   size       = getOct    124  12 header+   mtime      = getOct    136  12 header+   chksum     = getOct    148   8 header+   typecode   = getByte   156     header+   linkname   = getString 157 100 header+   magic      = getChars  257   8 header+   uname      = getString 265  32 header+   gname      = getString 297  32 header+   devmajor   = getOct    329   8 header+   devminor   = getOct    337   8 header+   prefix     = getString 345 155 header+--   trailing   = getBytes  500  12 header --TODO: check all \0's++   padding    = (512 - size) `mod` 512+   (cnt,bs'') = BS.splitAt size bs'+   bs'''      = BS.drop padding bs''++   entry      = Entry {+     filePath    = TarPath name prefix,+     fileMode    = mode,+     ownerId     = uid,+     groupId     = gid,+     fileSize    = size,+     modTime     = mtime,+     fileType    = fromFileTypeCode typecode,+     linkTarget  = linkname,+     headerExt   = case magic of+       "\0\0\0\0\0\0\0\0" -> V7+       "ustar\NUL00" -> USTAR {+         ownerName   = uname,+         groupName   = gname,+         deviceMajor = devmajor,+         deviceMinor = devminor+       }+       "ustar  \NUL" -> GNU {+         ownerName   = uname,+         groupName   = gname,+         deviceMajor = devmajor,+         deviceMinor = devminor+       }+       _ -> V7, --FIXME: fail instead+     fileContent = cnt+   }++correctChecksum :: ByteString -> Int -> Bool+correctChecksum header checksum = checksum == checksum'+  where+    -- sum of all 512 bytes in the header block,+    -- treating each byte as an 8-bit unsigned value+    checksum' = BS.Char8.foldl' (\x y -> x + ord y) 0 header'+    -- treating the 8 bytes of chksum as blank characters.+    header'   = BS.concat [BS.take 148 header,+                           BS.Char8.replicate 8 ' ',+                           BS.drop 156 header]++-- * TAR format primitive input++getOct :: Integral a => Int64 -> Int64 -> ByteString -> a+getOct off len = parseOct+               . BS.Char8.unpack+               . BS.Char8.takeWhile (\c -> c /= '\NUL' && c /= ' ')+               . getBytes off len+  where+    parseOct "" = 0+    parseOct s = case readOct s of+                   [(x,[])] -> x+                   _        -> error $ "Number format error: " ++ show s++getBytes :: Int64 -> Int64 -> ByteString -> ByteString+getBytes off len = BS.take len . BS.drop off++getByte :: Int64 -> ByteString -> Char+getByte off bs = BS.Char8.index bs off++getChars :: Int64 -> Int64 -> ByteString -> String+getChars off len = BS.Char8.unpack . getBytes off len++getString :: Int64 -> Int64 -> ByteString -> String+getString off len = BS.Char8.unpack . BS.Char8.takeWhile (/='\0') . getBytes off len++--+-- * Writing+--++-- | Creates an uncompressed archive+write :: [Entry] -> ByteString+write es = BS.concat $ map putEntry es ++ [BS.replicate (512*2) 0]++putEntry :: Entry -> ByteString+putEntry entry = BS.concat [ header, content, padding ]+  where+    header  = putHeader entry+    content = fileContent entry+    padding = BS.replicate paddingSize 0+    paddingSize = fromIntegral $ negate (fileSize entry) `mod` 512++putHeader :: Entry -> BS.ByteString+putHeader entry =+     BS.Char8.pack $ take 148 block+  ++ putOct 7 checksum+  ++ ' ' : drop 156 block+  where+    block    = putHeaderNoChkSum entry+    checksum = foldl' (\x y -> x + ord y) 0 block++putHeaderNoChkSum :: Entry -> String+putHeaderNoChkSum entry = concat+    [ putString  100 $ name+    , putOct       8 $ fileMode entry+    , putOct       8 $ ownerId entry+    , putOct       8 $ groupId entry+    , putOct      12 $ fileSize entry+    , putOct      12 $ modTime entry+    , fill         8 $ ' ' -- dummy checksum+    , putChar8       $ toFileTypeCode (fileType entry)+    , putString  100 $ linkTarget entry+    ] +++  case headerExt entry of+  V7    ->+      fill 255 '\NUL'+  ext@USTAR {}-> concat+    [ putString    8 $ "ustar\NUL00"+    , putString   32 $ ownerName ext+    , putString   32 $ groupName ext+    , putOct       8 $ deviceMajor ext+    , putOct       8 $ deviceMinor ext+    , putString  155 $ prefix+    , fill        12 $ '\NUL'+    ]+  ext@GNU {} -> concat+    [ putString    8 $ "ustar  \NUL"+    , putString   32 $ ownerName ext+    , putString   32 $ groupName ext+    , putGnuDev    8 $ deviceMajor ext+    , putGnuDev    8 $ deviceMinor ext+    , putString  155 $ prefix+    , fill        12 $ '\NUL'+    ]+  where+    TarPath name prefix = filePath entry+    putGnuDev w n = case fileType entry of+      CharacterDevice -> putOct w n+      BlockDevice     -> putOct w n+      _               -> replicate w '\NUL'+++-- * TAR format primitive output++type FieldWidth = Int++putString :: FieldWidth -> String -> String+putString n s = take n s ++ fill (n - length s) '\NUL'++putOct :: Integral a => FieldWidth -> a -> String+putOct n x =+  let octStr = take (n-1) $ showOct x ""+   in fill (n - length octStr - 1) '0'+   ++ octStr+   ++ putChar8 '\NUL'++putChar8 :: Char -> String+putChar8 c = [c]++fill :: FieldWidth -> Char -> String+fill n c = replicate n c++--+-- * Unpacking+--++unpack :: FilePath -> Entries -> IO ()+unpack dir 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'+      _            -> extractFiles links entries' -- FIXME: warning?+      where+        saveLink    = seq (length name)+                    $ seq (length name)+                    $ extractFiles (link:links) entries'+          where+            name    = fileName entry+            target  = linkTarget entry+            link    = (name, target)++    extractLinks = mapM_ $ \(name, target) ->+      let path      = dir </> name+       in copyFile (FilePath.Native.takeDirectory path </> target) path++--+-- * Packing+--++-- | Creates a tar archive from a directory of files, the paths in the archive+-- will be relative to the given base directory.+--+pack :: FilePath        -- ^ Base directory+     -> FilePath        -- ^ Directory or file to package, relative to the base dir+     -> IO [Entry]+pack baseDir sourceDir =+      mapM (unsafeInterleaveIO . uncurry (createFileEntry baseDir))+  =<< recurseDirectories [baseDir </> sourceDir]++recurseDirectories :: [FilePath] -> IO [(FileType, FilePath)]+recurseDirectories []         = return []+recurseDirectories (dir:dirs) = unsafeInterleaveIO $ do+  (files, dirs') <- collect [] [] =<< getDirectoryContents dir++  files' <- recurseDirectories (dirs' ++ dirs)+  return ((Directory, dir) : map ((,) NormalFile) files ++ files')++  where+    collect files dirs' []              = return (reverse files, reverse dirs')+    collect files dirs' (entry:entries) | ignore entry+                                        = collect files dirs' entries+    collect files dirs' (entry:entries) = do+      let dirEntry = dir </> entry+      isDirectory <- doesDirectoryExist dirEntry+      if isDirectory+        then collect files (dirEntry:dirs') entries+        else collect (dirEntry:files) dirs' entries++    ignore ['.']      = True+    ignore ['.', '.'] = True+    ignore _          = False++createFileEntry :: FilePath -- ^ path to find the file+                -> FileType+                -> FilePath -- ^ path to use for the tar Entry+                -> IO Entry+createFileEntry baseDir ftype absPath = do+  let relPath = FilePath.Native.makeRelative baseDir absPath+  tarpath <- either Prelude.fail return (toTarPath ftype relPath)+  mtime   <- getModTime absPath++  case ftype of+    NormalFile -> do+      file    <- openBinaryFile absPath ReadMode+      mode    <- getFileMode absPath+      size    <- hFileSize file+      content <- BS.hGetContents file+      return (emptyEntry NormalFile tarpath) {+        fileMode    = mode,+        modTime     = mtime,+        fileSize    = fromIntegral size,+        fileContent = content+      }+    _ ->+      return (emptyEntry Directory tarpath) {+        modTime     = mtime+      }++-- | We can't be precise because of portability, so we default to rw-r--r-- for+-- normal filesand rwxr-xr-x for executables.+getFileMode :: FilePath -> IO FileMode+getFileMode path = do+  perms <- getPermissions path+  if executable perms+    then return 0o0755+    else return 0o0644++getModTime :: FilePath -> IO EpochTime+getModTime path =+    do (TOD s _) <- getModificationTime path+       return (fromIntegral s)
+ Distribution/Client/Types.hs view
@@ -0,0 +1,110 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Types+-- Copyright   :  (c) David Himmelstrup 2005+-- License     :  BSD-like+--+-- Maintainer  :  lemmih@gmail.com+-- Stability   :  provisional+-- Portability :  portable+--+-- All data types for the entire cabal-install system gathered here to avoid some .hs-boot files.+-----------------------------------------------------------------------------+module Distribution.Client.Types where++import Distribution.Package+         ( PackageIdentifier(..), Package(..), PackageFixedDeps(..)+         , Dependency )+import Distribution.PackageDescription+         ( GenericPackageDescription, FlagAssignment )++import Network.URI (URI)+import Control.Exception+         ( Exception )++newtype Username = Username { unUsername :: String }+newtype Password = Password { unPassword :: String }++-- | A 'ConfiguredPackage' is a not-yet-installed package along with the+-- total configuration information. The configuration information is total in+-- the sense that it provides all the configuration information and so the+-- final configure process will be independent of the environment.+--+data ConfiguredPackage = ConfiguredPackage+       AvailablePackage    -- package info, including repo+       FlagAssignment      -- complete flag assignment for the package+       [PackageIdentifier] -- set of exact dependencies. These must be+                           -- consistent with the 'buildDepends' in the+                           -- 'PackageDescrption' that you'd get by applying+                           -- the flag assignment.+  deriving Show++instance Package ConfiguredPackage where+  packageId (ConfiguredPackage pkg _ _) = packageId pkg++instance PackageFixedDeps ConfiguredPackage where+  depends (ConfiguredPackage _ _ deps) = deps+++-- | We re-use @GenericPackageDescription@ and use the @package-url@+-- field to store the tarball URI.+data AvailablePackage = AvailablePackage {+    packageInfoId      :: PackageIdentifier,+    packageDescription :: GenericPackageDescription,+    packageSource      :: AvailablePackageSource+  }+  deriving Show++instance Package AvailablePackage where packageId = packageInfoId++data AvailablePackageSource =++    -- | The unpacked package in the current dir+    LocalUnpackedPackage++    -- | A package available as a tarball from a repository.+    --+    -- It may be from a local repository or from a remote repository, with a+    -- locally cached copy. ie a package available from hackage+  | RepoTarballPackage Repo++--  | ScmPackage+  deriving Show++--TODO:+--  * generalise local package to any local unpacked package, not just in the+--      current dir, ie add a FilePath param+--  * add support for darcs and other SCM style remote repos with a local cache++data LocalRepo = LocalRepo+  deriving (Show,Eq)++data RemoteRepo = RemoteRepo {+    remoteRepoName :: String,+    remoteRepoURI  :: URI+  }+  deriving (Show,Eq)++data Repo = Repo {+    repoKind     :: Either RemoteRepo LocalRepo,+    repoLocalDir :: FilePath+  }+  deriving (Show,Eq)++data UnresolvedDependency+    = UnresolvedDependency+    { dependency :: Dependency+    , depFlags   :: FlagAssignment+    }+  deriving (Show)++type BuildResult  = Either BuildFailure BuildSuccess+data BuildFailure = DependentFailed PackageIdentifier+                  | UnpackFailed    Exception+                  | ConfigureFailed Exception+                  | BuildFailed     Exception+                  | InstallFailed   Exception+data BuildSuccess = BuildOk         DocsResult TestsResult++data DocsResult  = DocsNotTried  | DocsFailed  | DocsOk+data TestsResult = TestsNotTried | TestsFailed | TestsOk
+ Distribution/Client/Update.hs view
@@ -0,0 +1,43 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Update+-- Copyright   :  (c) David Himmelstrup 2005+-- License     :  BSD-like+--+-- Maintainer  :  lemmih@gmail.com+-- Stability   :  provisional+-- Portability :  portable+--+--+-----------------------------------------------------------------------------+module Distribution.Client.Update+    ( update+    ) where++import Distribution.Client.Types+         ( Repo(..), RemoteRepo(..), LocalRepo(..) )+import Distribution.Client.Fetch+         ( downloadIndex )+import qualified Distribution.Client.Utils as BS+         ( writeFileAtomic )++import Distribution.Simple.Utils (notice)+import Distribution.Verbosity (Verbosity)++import qualified Data.ByteString.Lazy as BS+import qualified Codec.Compression.GZip as GZip (decompress)+import System.FilePath (dropExtension)++-- | 'update' downloads the package list from all known servers+update :: Verbosity -> [Repo] -> IO ()+update verbosity = mapM_ (updateRepo verbosity)++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) ++ "'"+    indexPath <- downloadIndex verbosity remoteRepo (repoLocalDir repo)+    BS.writeFileAtomic (dropExtension indexPath) . GZip.decompress+                                               =<< BS.readFile indexPath
+ Distribution/Client/Upload.hs view
@@ -0,0 +1,170 @@+-- This is a quick hack for uploading packages to Hackage.+-- See http://hackage.haskell.org/trac/hackage/wiki/CabalUpload++module Distribution.Client.Upload (check, upload, report) where++import Distribution.Client.Types (Username(..), Password(..),Repo(..),RemoteRepo(..))+import Distribution.Client.HttpUtils (proxy, isOldHackageURI)++import Distribution.Simple.Utils (debug, notice, warn, info)+import Distribution.Verbosity (Verbosity)+import Distribution.Text (display)+import Distribution.Client.Config++import qualified Distribution.Client.BuildReports.Anonymous as BuildReport+import qualified Distribution.Client.BuildReports.Upload as BuildReport++import Network.Browser+         ( BrowserAction, browse, request+         , Authority(..), addAuthority, setAuthorityGen+         , setOutHandler, setErrHandler, setProxy )+import Network.HTTP+         ( Header(..), HeaderName(..), findHeader+         , Request(..), RequestMethod(..), Response(..) )+import Network.URI (URI(uriPath), parseURI)++import Data.Char        (intToDigit)+import Numeric          (showHex)+import System.IO        (hFlush, stdin, stdout, hGetEcho, hSetEcho+                        ,openBinaryFile, IOMode(ReadMode), hGetContents)+import Control.Exception (bracket)+import System.Random    (randomRIO)+import System.FilePath  ((</>), takeExtension)+import qualified System.FilePath.Posix as FilePath.Posix (combine)+import System.Directory+import Control.Monad (forM_)+++--FIXME: how do we find this path for an arbitrary hackage server?+-- is it always at some fixed location relative to the server root?+legacyUploadURI :: URI+Just legacyUploadURI = parseURI "http://hackage.haskell.org/cgi-bin/hackage-scripts/protected/upload-pkg"++checkURI :: URI+Just checkURI = parseURI "http://hackage.haskell.org/cgi-bin/hackage-scripts/check-pkg"+++upload :: Verbosity -> [Repo] -> Maybe Username -> Maybe Password -> [FilePath] -> IO ()+upload verbosity repos mUsername mPassword paths = do+          let uploadURI = if isOldHackageURI targetRepoURI+                          then legacyUploadURI+                          else targetRepoURI{uriPath = uriPath targetRepoURI `FilePath.Posix.combine` "upload"}+          Username username <- maybe promptUsername return mUsername+          Password password <- maybe promptPassword return mPassword+          let auth = addAuthority AuthBasic {+                       auRealm    = "Hackage",+                       auUsername = username,+                       auPassword = password,+                       auSite     = uploadURI+                     }+          flip mapM_ paths $ \path -> do+            notice verbosity $ "Uploading " ++ path ++ "... "+            handlePackage verbosity uploadURI auth path+  where+    targetRepoURI = remoteRepoURI $ last [ remoteRepo | Left remoteRepo <- map repoKind repos ] --FIXME: better error message when no repos are given+    promptUsername :: IO Username+    promptUsername = do+      putStr "Hackage username: "+      hFlush stdout+      fmap Username getLine++    promptPassword :: IO Password+    promptPassword = do+      putStr "Hackage password: "+      hFlush stdout+      -- save/restore the terminal echoing status+      bracket (hGetEcho stdin) (hSetEcho stdin) $ \_ -> do+        hSetEcho stdin False  -- no echoing for entering the password+        fmap Password getLine++report :: Verbosity -> [Repo] -> IO ()+report verbosity repos+    = forM_ repos $ \repo ->+      case repoKind repo of+        Left remoteRepo+            -> do dotCabal <- defaultCabalDir+                  let srcDir = dotCabal </> "reports" </> remoteRepoName remoteRepo+                  contents <- getDirectoryContents srcDir+                  forM_ (filter (\c -> takeExtension c == ".log") contents) $ \logFile ->+                      do inp <- readFile (srcDir </> logFile)+                         let (reportStr, buildLog) = read inp :: (String,String)+                         case BuildReport.parse reportStr of+                           Left errs -> do warn verbosity $ "Errors: " ++ errs -- FIXME+                           Right report' ->+                               do info verbosity $ "Uploading report for " ++ display (BuildReport.package report')+                                  browse $ BuildReport.uploadReports (remoteRepoURI remoteRepo) [(report', Just buildLog)]+                                  return ()+        Right{} -> return ()++check :: Verbosity -> [FilePath] -> IO ()+check verbosity paths = do+          flip mapM_ paths $ \path -> do+            notice verbosity $ "Checking " ++ path ++ "... "+            handlePackage verbosity checkURI (return ()) path++handlePackage :: Verbosity -> URI -> BrowserAction () -> FilePath -> IO ()+handlePackage verbosity uri auth path =+  do req <- mkRequest uri path+     p   <- proxy verbosity+     debug verbosity $ "\n" ++ show req+     (_,resp) <- browse $ do+                   setProxy p+                   setErrHandler (warn verbosity . ("http error: "++))+                   setOutHandler (debug verbosity)+                   auth+                   setAuthorityGen (\_ _ -> return Nothing)+                   request req+     debug verbosity $ show resp+     case rspCode resp of+       (2,0,0) -> do notice verbosity "OK"+       (x,y,z) -> do notice verbosity $ "ERROR: " ++ path ++ ": " +                                     ++ map intToDigit [x,y,z] ++ " "+                                     ++ rspReason resp+                     case findHeader HdrContentType resp of+                       Just "text/plain" -> notice verbosity $ rspBody resp+                       _                 -> debug verbosity $ rspBody resp++mkRequest :: URI -> FilePath -> IO Request+mkRequest uri path = +    do pkg <- readBinaryFile path+       boundary <- genBoundary+       let body = printMultiPart boundary (mkFormData path pkg)+       return $ Request {+                         rqURI = uri,+                         rqMethod = POST,+                         rqHeaders = [Header HdrContentType ("multipart/form-data; boundary="++boundary),+                                      Header HdrContentLength (show (length body)),+                                      Header HdrAccept ("text/plain")],+                         rqBody = body+                        }++readBinaryFile :: FilePath -> IO String+readBinaryFile path = openBinaryFile path ReadMode >>= hGetContents++genBoundary :: IO String+genBoundary = do i <- randomRIO (0x10000000000000,0xFFFFFFFFFFFFFF) :: IO Integer+                 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]++hdrContentDisposition :: HeaderName+hdrContentDisposition = HdrCustom "Content-disposition"++-- * Multipart, partly stolen from the cgi package.++data BodyPart = BodyPart [Header] String++printMultiPart :: String -> [BodyPart] -> String+printMultiPart boundary xs = +    concatMap (printBodyPart boundary) xs ++ crlf ++ "--" ++ boundary ++ "--" ++ crlf++printBodyPart :: String -> BodyPart -> String+printBodyPart boundary (BodyPart hs c) = crlf ++ "--" ++ boundary ++ crlf ++ concatMap show hs ++ crlf ++ c++crlf :: String+crlf = "\r\n"
+ Distribution/Client/Utils.hs view
@@ -0,0 +1,59 @@+module Distribution.Client.Utils where++import Data.List+         ( sortBy, groupBy )+import qualified Data.ByteString.Lazy as BS+import System.FilePath+         ( (<.>), splitFileName )+import System.IO+         ( openBinaryTempFile, hClose )+import System.Directory+         ( removeFile, renameFile )+import qualified Control.Exception as Exception+         ( handle, throwIO )++-- | Generic merging utility. For sorted input lists this is a full outer join.+--+-- * The result list never contains @(Nothing, Nothing)@.+--+mergeBy :: (a -> b -> Ordering) -> [a] -> [b] -> [MergeResult a b]+mergeBy cmp = merge+  where+    merge []     ys     = [ OnlyInRight y | y <- ys]+    merge xs     []     = [ OnlyInLeft  x | x <- xs]+    merge (x:xs) (y:ys) =+      case x `cmp` y of+        GT -> OnlyInRight   y : merge (x:xs) ys+        EQ -> InBoth      x y : merge xs     ys+        LT -> OnlyInLeft  x   : merge xs  (y:ys)++data MergeResult a b = OnlyInLeft a | InBoth a b | OnlyInRight b++duplicates :: Ord a => [a] -> [[a]]+duplicates = duplicatesBy compare++duplicatesBy :: (a -> a -> Ordering) -> [a] -> [[a]]+duplicatesBy cmp = filter moreThanOne . groupBy eq . sortBy cmp+  where+    eq a b = case cmp a b of+               EQ -> True+               _  -> False+    moreThanOne (_:_:_) = True+    moreThanOne _       = False++writeFileAtomic :: FilePath -> BS.ByteString -> IO ()+writeFileAtomic targetFile content = do+  (tmpFile, tmpHandle) <- openBinaryTempFile targetDir template+  Exception.handle (\err -> do hClose tmpHandle+                               removeFile tmpFile+                               Exception.throwIO err) $ do+      BS.hPut tmpHandle content+      hClose tmpHandle+      renameFile tmpFile targetFile+  where+    template = targetName <.> "tmp"+    targetDir | null targetDir_ = "."+              | otherwise       = targetDir_+    --TODO: remove this when takeDirectory/splitFileName is fixed+    --      to always return a valid dir+    (targetDir_,targetName) = splitFileName targetFile
+ Distribution/Client/Win32SelfUpgrade.hs view
@@ -0,0 +1,225 @@+{-# 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 #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Win32SelfUpgrade+-- Copyright   :  (c) Duncan Coutts 2008+-- License     :  BSD-like+--+-- Maintainer  :  cabal-devel@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- Support for self-upgrading executables on Windows platforms.+-----------------------------------------------------------------------------+module Distribution.Client.Win32SelfUpgrade (+-- * Explanation+--+-- | Windows inherited a design choice from DOS that while initially innocuous+-- has rather unfortunate consequences. It maintains the invariant that every+-- open file has a corresponding name on disk. One positive consequence of this+-- is that an executable can always find it's own executable file. The downside+-- is that a program cannot be deleted or upgraded while it is running without+-- hideous workarounds. This module implements one such hideous workaround.+--+-- The basic idea is:+--+-- * Move our own exe file to a new name+-- * Copy a new exe file to the previous name+-- * Run the new exe file, passing our own pid and new path+-- * Wait for the new process to start+-- * Close the new exe file+-- * Exit old process+--+-- Then in the new process:+--+-- * Inform the old process that we've started+-- * Wait for the old process to die+-- * Delete the old exe file+-- * Exit new process+--++    possibleSelfUpgrade,+    deleteOldExeFile,+  ) where++#if mingw32_HOST_OS || mingw32_TARGET_OS++import qualified System.Win32 as Win32+import qualified System.Win32.DLL as Win32+import System.Win32 (DWORD, BOOL, HANDLE, LPCTSTR)+import Foreign.Ptr (Ptr, nullPtr)+import System.Process (runProcess)+import System.Directory (canonicalizePath)+import System.FilePath (takeBaseName, replaceBaseName, equalFilePath)++import Distribution.Verbosity as Verbosity (Verbosity, showForCabal)+import Distribution.Simple.Utils (debug, info)++import Prelude hiding (log)++-- | If one of the given files is our own exe file then we arrange things such+-- that the nested action can replace our own exe file.+--+-- We require that the new process accepts a command line invocation that+-- calls 'deleteOldExeFile', passing in the pid and exe file.+--+possibleSelfUpgrade :: Verbosity+                    -> [FilePath]+                    -> IO a -> IO a+possibleSelfUpgrade verbosity newPaths action = do+  dstPath <- canonicalizePath =<< Win32.getModuleFileName Win32.nullHANDLE++  newPaths' <- mapM canonicalizePath newPaths+  let doingSelfUpgrade = any (equalFilePath dstPath) newPaths'++  if not doingSelfUpgrade+    then action+    else do+      info verbosity $ "cabal-install does the replace-own-exe-file dance..."+      tmpPath <- moveOurExeOutOfTheWay verbosity+      result <- action+      scheduleOurDemise verbosity dstPath tmpPath+        (\pid path -> ["win32selfupgrade", pid, path+                      ,"--verbose=" ++ Verbosity.showForCabal verbosity])+      return result++-- | The name of a Win32 Event object that we use to synchronise between the+-- old and new processes. We need to synchronise to make sure that the old+-- process has not yet terminated by the time the new one starts up and looks+-- for the old process. Otherwise the old one might have already terminated+-- and we could not wait on it terminating reliably (eg the pid might get+-- re-used).+--+syncEventName :: String+syncEventName = "Local\\cabal-install-upgrade"++-- | The first part of allowing our exe file to be replaced is to move the+-- existing exe file out of the way. Although we cannot delete our exe file+-- while we're still running, fortunately we can rename it, at least within+-- the same directory.+--+moveOurExeOutOfTheWay :: Verbosity -> IO FilePath+moveOurExeOutOfTheWay verbosity = do+  ourPID  <-       getCurrentProcessId+  dstPath <- Win32.getModuleFileName Win32.nullHANDLE++  let tmpPath = replaceBaseName dstPath (takeBaseName dstPath ++ show ourPID)++  debug verbosity $ "moving " ++ dstPath ++ " to " ++ tmpPath+  Win32.moveFile dstPath tmpPath+  return tmpPath++-- | Assuming we've now installed the new exe file in the right place, we+-- launch it and ask it to delete our exe file when we eventually terminate.+--+scheduleOurDemise :: Verbosity -> FilePath -> FilePath+                  -> (String -> FilePath -> [String]) -> IO ()+scheduleOurDemise verbosity dstPath tmpPath mkArgs = do+  ourPID <- getCurrentProcessId+  event  <- createEvent syncEventName++  let args = mkArgs (show ourPID) tmpPath+  log $ "launching child " ++ unwords (dstPath : map show args)+  runProcess dstPath args Nothing Nothing Nothing Nothing Nothing++  log $ "waiting for the child to start up"+  waitForSingleObject event (10*1000) -- wait at most 10 sec+  log $ "child started ok"++  where+    log msg = debug verbosity ("Win32Reinstall.parent: " ++ msg)++-- | Assuming we're now in the new child process, we've been asked by the old+-- process to wait for it to terminate and then we can remove the old exe file+-- that it renamted itself to.+--+deleteOldExeFile :: Verbosity -> Int -> FilePath -> IO ()+deleteOldExeFile verbosity oldPID tmpPath = do+  log $ "process started. Will delete exe file of process "+     ++ show oldPID ++ " at path " ++ tmpPath++  log $ "getting handle of parent process " ++ show oldPID+  oldPHANDLE <- Win32.openProcess Win32.sYNCHORNIZE False (fromIntegral oldPID)++  log $ "synchronising with parent"+  event <- openEvent syncEventName+  setEvent event++  log $ "waiting for parent process to terminate"+  waitForSingleObject oldPHANDLE Win32.iNFINITE+  log $ "parent process terminated"++  log $ "deleting parent's old .exe file"+  Win32.deleteFile tmpPath++  where+    log msg = debug verbosity ("Win32Reinstall.child: " ++ msg)++------------------------+-- Win32 foreign imports+--++-- A bunch of functions sadly not provided by the Win32 package.++foreign import stdcall unsafe "windows.h GetCurrentProcessId"+  getCurrentProcessId :: IO DWORD++foreign import stdcall unsafe "windows.h WaitForSingleObject"+  waitForSingleObject_ :: HANDLE -> DWORD -> IO DWORD++waitForSingleObject :: HANDLE -> DWORD -> IO ()+waitForSingleObject handle timeout =+  Win32.failIf_ bad "WaitForSingleObject" $+    waitForSingleObject_ handle timeout+  where+    bad result   = not (result == 0 || result == wAIT_TIMEOUT)+    wAIT_TIMEOUT = 0x00000102++foreign import stdcall unsafe "windows.h CreateEventW"+  createEvent_ :: Ptr () -> BOOL -> BOOL -> LPCTSTR -> IO HANDLE++createEvent :: String -> IO HANDLE+createEvent name = do+  Win32.failIfNull "CreateEvent" $+    Win32.withTString name $+      createEvent_ nullPtr False False++foreign import stdcall unsafe "windows.h OpenEventW"+  openEvent_ :: DWORD -> BOOL -> LPCTSTR -> IO HANDLE++openEvent :: String -> IO HANDLE+openEvent name = do+  Win32.failIfNull "OpenEvent" $+    Win32.withTString name $+      openEvent_ eVENT_MODIFY_STATE False+  where+    eVENT_MODIFY_STATE :: DWORD+    eVENT_MODIFY_STATE = 0x0002++foreign import stdcall unsafe "windows.h SetEvent"+  setEvent_ :: HANDLE -> IO BOOL++setEvent :: HANDLE -> IO ()+setEvent handle =+  Win32.failIfFalse_ "SetEvent" $+    setEvent_ handle++#else++import Distribution.Verbosity (Verbosity)+import Distribution.Simple.Utils (die)++possibleSelfUpgrade :: Verbosity+                    -> [FilePath]+                    -> IO a -> IO a+possibleSelfUpgrade _ _ action = action++deleteOldExeFile :: Verbosity -> Int -> FilePath -> IO ()+deleteOldExeFile _ _ _ = die "win32selfupgrade not needed except on win32"++#endif
− Hackage/Check.hs 
@@ -1,81 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Hackage.Check--- Copyright   :  (c) Lennart Kolmodin 2008--- License     :  BSD-like------ Maintainer  :  kolmodin@haskell.org--- Stability   :  provisional--- Portability :  portable------ Check a package for common mistakes----------------------------------------------------------------------------------module Hackage.Check (-    check-  ) where--import Control.Monad ( when, unless )--import Distribution.PackageDescription ( readPackageDescription )-import Distribution.PackageDescription.Check-import Distribution.PackageDescription.Configuration ( flattenPackageDescription )-import Distribution.Verbosity ( Verbosity )-import Distribution.Simple.Utils ( defaultPackageDesc, toUTF8 )--check :: Verbosity -> IO Bool-check verbosity = do-    pdfile <- defaultPackageDesc verbosity-    ppd <- readPackageDescription verbosity pdfile-    -- flatten the generic package description into a regular package-    -- description-    -- TODO: this may give more warnings than it should give;-    --       consider two branches of a condition, one saying-    --          ghc-options: -Wall-    --       and the other-    --          ghc-options: -Werror-    --      joined into-    --          ghc-options: -Wall -Werror-    --      checkPackages will yield a warning on the last line, but it-    --      would not on each individual branch.-    --      Hovever, this is the same way hackage does it, so we will yield-    --      the exact same errors as it will.-    let pkg_desc = flattenPackageDescription ppd-    ioChecks <- checkPackageFiles pkg_desc "."-    let packageChecks = ioChecks ++ checkPackage ppd (Just pkg_desc)-        buildImpossible = [ x | x@PackageBuildImpossible {} <- packageChecks ]-        buildWarning    = [ x | x@PackageBuildWarning {}    <- packageChecks ]-        distSuspicious  = [ x | x@PackageDistSuspicious {}  <- packageChecks ]-        distInexusable  = [ x | x@PackageDistInexcusable {} <- packageChecks ]--    unless (null buildImpossible) $ do-        putStrLn "The package will not build sanely due to these errors:"-        mapM_ (putStrLn . toUTF8. explanation) buildImpossible-        putStrLn ""--    unless (null buildWarning) $ do-        putStrLn "The following warnings are likely affect your build negatively:"-        mapM_ (putStrLn . toUTF8 . explanation) buildWarning-        putStrLn ""--    unless (null distSuspicious) $ do-        putStrLn "These warnings may cause trouble when distributing the package:"-        mapM_ (putStrLn . toUTF8 . explanation) distSuspicious-        putStrLn ""--    unless (null distInexusable) $ do-        putStrLn "The following errors will cause portability problems on other environments:"-        mapM_ (putStrLn . toUTF8 . explanation) distInexusable-        putStrLn ""--    let isDistError (PackageDistSuspicious {}) = False-        isDistError _                          = True-        errors = filter isDistError packageChecks--    unless (null errors) $ do-        putStrLn "Hackage would reject this package."--    when (null packageChecks) $ do-        putStrLn "No errors or warnings could be found in the package."--    return (null packageChecks)
− Hackage/Config.hs 
@@ -1,284 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Hackage.Config--- Copyright   :  (c) David Himmelstrup 2005--- License     :  BSD-like------ Maintainer  :  lemmih@gmail.com--- Stability   :  provisional--- Portability :  portable------ Utilities for handling saved state such as known packages, known servers and downloaded packages.-------------------------------------------------------------------------------module Hackage.Config-    ( SavedConfig(..)-    , savedConfigToConfigFlags-    , configRepos-    , configPackageDB-    , defaultConfigFile-    , defaultCacheDir-    , loadConfig-    , showConfig-    ) where--import Prelude hiding (catch)-import Data.Char (isAlphaNum)-import Data.Maybe (fromMaybe)-import Control.Monad (when)-import Data.Monoid (Monoid(..))-import System.Directory (createDirectoryIfMissing, getAppUserDataDirectory)-import System.FilePath ((</>), takeDirectory)-import Network.URI (parseAbsoluteURI, uriToString)-import Text.PrettyPrint.HughesPJ (text)--import Distribution.Compat.ReadP as ReadP-         ( ReadP, char, munch1, pfail )-import Distribution.Compiler (CompilerFlavor(..), defaultCompilerFlavor)-import Distribution.ParseUtils-         ( FieldDescr(..), simpleField, listField, liftField, field-         , parseFilePathQ, parseTokenQ, showPWarning, ParseResult(..) )-import Distribution.Simple.Compiler (PackageDB(..))-import Distribution.Simple.InstallDirs-         ( InstallDirs(..), PathTemplate, toPathTemplate, fromPathTemplate )-import Distribution.Simple.Command (ShowOrParseArgs(..), viewAsFieldDescr)-import Distribution.Simple.Setup-         ( Flag(..), toFlag, fromFlag, fromFlagOrDefault-         , ConfigFlags, configureOptions )-import qualified Distribution.Simple.Setup as ConfigFlags-import qualified Distribution.Simple.Setup as Cabal-import Distribution.Verbosity (Verbosity, normal)-import Distribution.System-         ( OS(Windows), buildOS )--import Hackage.Types-         ( RemoteRepo(..), Repo(..), Username(..), Password(..) )-import Hackage.ParseUtils-import Hackage.Utils (readFileIfExists)-import Distribution.Simple.Utils (notice, warn)--configPackageDB :: Cabal.ConfigFlags -> PackageDB-configPackageDB config =-  fromFlagOrDefault defaultDB (Cabal.configPackageDB config)-  where-    defaultDB = case Cabal.configUserInstall config of-      NoFlag     -> UserPackageDB-      Flag True  -> UserPackageDB-      Flag False -> GlobalPackageDB------- * Configuration saved in the config file-----data SavedConfig = SavedConfig {-    configCacheDir          :: Flag FilePath,-    configRemoteRepos       :: [RemoteRepo],     -- ^Available Hackage servers.-    configUploadUsername    :: Flag Username,-    configUploadPassword    :: Flag Password,-    configUserInstallDirs   :: InstallDirs (Flag PathTemplate),-    configGlobalInstallDirs :: InstallDirs (Flag PathTemplate),-    configFlags             :: ConfigFlags-  }--configUserInstall     :: SavedConfig -> Flag Bool-configUserInstall     =  ConfigFlags.configUserInstall . configFlags--configRepos :: SavedConfig -> [Repo]-configRepos config =-  [ let cacheDir = fromFlag (configCacheDir config)-               </> remoteRepoName remote-     in Repo remote cacheDir-  | remote <- configRemoteRepos config ]--savedConfigToConfigFlags :: Flag Bool -> SavedConfig -> Cabal.ConfigFlags-savedConfigToConfigFlags userInstallFlag config = (configFlags config) {-    Cabal.configUserInstall = toFlag userInstall,-    Cabal.configInstallDirs = if userInstall-                                then configUserInstallDirs config-                                else configGlobalInstallDirs config-  }-  where userInstall :: Bool-        userInstall = fromFlag $ configUserInstall config-                       `mappend` userInstallFlag------- * Default config-----defaultCabalDir :: IO FilePath-defaultCabalDir = getAppUserDataDirectory "cabal"--defaultConfigFile :: IO FilePath-defaultConfigFile = do dir <- defaultCabalDir-                       return $ dir </> "config"--defaultCacheDir :: IO FilePath-defaultCacheDir = do dir <- defaultCabalDir-                     return $ dir </> "packages"--defaultCompiler :: CompilerFlavor-defaultCompiler = fromMaybe GHC defaultCompilerFlavor--defaultUserInstall :: Bool-defaultUserInstall = case buildOS of-  -- We do global installs by default on Windows-  Windows -> False-  -- and per-user installs by default everywhere else-  _       -> True--defaultUserInstallDirs :: IO (InstallDirs (Flag PathTemplate))-defaultUserInstallDirs =-    do userPrefix <- defaultCabalDir-       return $ defaultGlobalInstallDirs {-         prefix = toFlag (toPathTemplate userPrefix)-       }--defaultGlobalInstallDirs :: InstallDirs (Flag PathTemplate)-defaultGlobalInstallDirs = mempty--defaultSavedConfig :: IO SavedConfig-defaultSavedConfig =-    do userInstallDirs <- defaultUserInstallDirs-       cacheDir        <- defaultCacheDir-       return SavedConfig {-           configFlags = mempty {-               ConfigFlags.configHcFlavor    = toFlag defaultCompiler-             , ConfigFlags.configVerbosity   = toFlag normal-             , ConfigFlags.configUserInstall = toFlag defaultUserInstall-             , ConfigFlags.configInstallDirs = error-               "ConfigFlags.installDirs: avoid this field. Use UserInstallDirs \-              \ or GlobalInstallDirs instead"-             }-         , configUserInstallDirs   = userInstallDirs-         , configGlobalInstallDirs = defaultGlobalInstallDirs-         , configCacheDir          = toFlag cacheDir-         , configRemoteRepos       = [defaultRemoteRepo]-         , configUploadUsername    = mempty-         , configUploadPassword    = mempty-         }--defaultRemoteRepo :: RemoteRepo-defaultRemoteRepo = RemoteRepo "hackage.haskell.org" uri-  where-    Just uri = parseAbsoluteURI "http://hackage.haskell.org/packages/archive"------- * Config file reading-----loadConfig :: Verbosity -> FilePath -> IO SavedConfig-loadConfig verbosity configFile = -    do defaultConf <- defaultSavedConfig-       minp <- readFileIfExists configFile-       case minp of-         Nothing -> do notice verbosity $ "Config file " ++ configFile ++ " not found."-                       notice verbosity $ "Writing default configuration to " ++ configFile-                       writeDefaultConfigFile configFile defaultConf-                       return defaultConf-         Just inp -> case parseBasicStanza configFieldDescrs defaultConf' inp of-                       ParseOk ws conf -> -                           do when (not $ null ws) $ warn verbosity $-                                unlines (map (showPWarning configFile) ws)-                              return conf-                       ParseFailed err -> -                           do warn verbosity $ "Error parsing config file " -                                            ++ configFile ++ ": " ++ showPError err-                              warn verbosity $ "Using default configuration."-                              return defaultConf-           where defaultConf' = defaultConf { configRemoteRepos = [] }--writeDefaultConfigFile :: FilePath -> SavedConfig -> IO ()-writeDefaultConfigFile file cfg = -    do createDirectoryIfMissing True (takeDirectory file)-       writeFile file $ showFields configWriteFieldDescrs cfg ++ "\n"--showConfig :: SavedConfig -> String-showConfig = showFields configFieldDescrs---- | All config file fields.-configFieldDescrs :: [FieldDescr SavedConfig]-configFieldDescrs =-    map ( configFlagsField . viewAsFieldDescr) (configureOptions ShowArgs)-    ++ configCabalInstallFieldDescrs-    ++ map userInstallDirField installDirDescrs-    ++ map globalInstallDirField installDirDescrs--configCabalInstallFieldDescrs :: [FieldDescr SavedConfig]-configCabalInstallFieldDescrs =-    [ listField "repos"-                (text . showRepo)                  parseRepo-                configRemoteRepos (\rs cfg -> cfg { configRemoteRepos = rs })-    , simpleField "cachedir"-                (text . show . fromFlagOrDefault "")-                (fmap emptyToNothing parseFilePathQ)-                configCacheDir    (\d cfg -> cfg { configCacheDir = d })-    , simpleField "hackage-username"-                (text . show . fromFlagOrDefault "" . fmap unUsername)-                (fmap (fmap Username . emptyToNothing) parseTokenQ)-                configUploadUsername    (\d cfg -> cfg { configUploadUsername = d })-    , simpleField "hackage-password"-                (text . show . fromFlagOrDefault "" . fmap unPassword)-                (fmap (fmap Password . emptyToNothing) parseTokenQ)-                configUploadPassword    (\d cfg -> cfg { configUploadPassword = d })-    ]-    where emptyToNothing "" = mempty-          emptyToNothing f  = toFlag f-                              --- | The subset of the config file fields that we write out--- if the config file is missing.-configWriteFieldDescrs :: [FieldDescr SavedConfig]-configWriteFieldDescrs = configCabalInstallFieldDescrs-                         ++ [f | f <- configFieldDescrs, fieldName f `elem` ["compiler", "user-install"]]--installDirDescrs :: [FieldDescr (InstallDirs (Flag PathTemplate))]-installDirDescrs =-    [ installDirField "prefix"     prefix     (\d ds -> ds { prefix     = d })-    , installDirField "bindir"     bindir     (\d ds -> ds { bindir     = d })-    , installDirField "libdir"     libdir     (\d ds -> ds { libdir     = d })-    , installDirField "libexecdir" libexecdir (\d ds -> ds { libexecdir = d })-    , installDirField "datadir"    datadir    (\d ds -> ds { datadir    = d })-    , installDirField "docdir"     docdir     (\d ds -> ds { docdir     = d })-    , installDirField "htmldir"    htmldir    (\d ds -> ds { htmldir    = d })-    ]--configFlagsField :: FieldDescr ConfigFlags -> FieldDescr SavedConfig-configFlagsField = liftField configFlags (\ff cfg -> cfg{configFlags=ff})---userInstallDirField :: FieldDescr (InstallDirs (Flag PathTemplate)) -> FieldDescr SavedConfig-userInstallDirField f = modifyFieldName ("user-"++) $-    liftField configUserInstallDirs -              (\d cfg -> cfg { configUserInstallDirs = d }) -              f--globalInstallDirField :: FieldDescr (InstallDirs (Flag PathTemplate)) -> FieldDescr SavedConfig-globalInstallDirField f = modifyFieldName ("global-"++) $-    liftField configGlobalInstallDirs -              (\d cfg -> cfg { configGlobalInstallDirs = d }) -              f--installDirField :: String -                -> (InstallDirs (Flag PathTemplate) -> Flag PathTemplate) -                -> (Flag PathTemplate -> InstallDirs (Flag PathTemplate) -> InstallDirs (Flag PathTemplate))-                -> FieldDescr (InstallDirs (Flag PathTemplate))-installDirField name get set = -    liftField get set $-      field name (text . fromPathTemplate . fromFlag)-                 (fmap (toFlag . toPathTemplate) parseFilePathQ)--modifyFieldName :: (String -> String) -> FieldDescr a -> FieldDescr a-modifyFieldName f d = d { fieldName = f (fieldName d) }--showRepo :: RemoteRepo -> String-showRepo repo = remoteRepoName repo ++ ":"-             ++ uriToString id (remoteRepoURI repo) []--parseRepo :: ReadP r RemoteRepo-parseRepo = do name <- munch1 (\c -> isAlphaNum c || c `elem` "_-.")-               char ':'-               uriStr <- munch1 (\c -> isAlphaNum c || c `elem` "+-=._/*()@'$:;&!?")-               uri <- maybe ReadP.pfail return (parseAbsoluteURI uriStr)-               return $ RemoteRepo {-                 remoteRepoName = name,-                 remoteRepoURI  = uri-               }-
− Hackage/Dependency.hs 
@@ -1,180 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Hackage.Dependency--- Copyright   :  (c) David Himmelstrup 2005,---                    Bjorn Bringert 2007---                    Duncan Coutts 2008--- License     :  BSD-like------ Maintainer  :  cabal-devel@gmail.com--- Stability   :  provisional--- Portability :  portable------ Top level interface to dependency resolution.-------------------------------------------------------------------------------module Hackage.Dependency (-    resolveDependencies,-    resolveDependenciesWithProgress,-    PackagesVersionPreference(..),-    upgradableDependencies,-  ) where----import Hackage.Dependency.Naive (naiveResolver)-import Hackage.Dependency.Bogus (bogusResolver)-import Hackage.Dependency.TopDown (topDownResolver)-import qualified Distribution.Simple.PackageIndex as PackageIndex-import Distribution.Simple.PackageIndex (PackageIndex)-import Distribution.InstalledPackageInfo (InstalledPackageInfo)-import qualified Hackage.InstallPlan as InstallPlan-import Hackage.InstallPlan (InstallPlan)-import Hackage.Types-         ( UnresolvedDependency(..), AvailablePackage(..) )-import Hackage.Dependency.Types-         ( PackageName, DependencyResolver, PackageVersionPreference(..)-         , Progress(..), foldProgress )-import Distribution.Package-         ( PackageIdentifier(..), packageVersion, packageName-         , Dependency(..), Package(..), PackageFixedDeps(..) )-import Distribution.Version-         ( VersionRange(LaterVersion) )-import Distribution.Compiler-         ( CompilerId )-import Distribution.System-         ( OS, Arch )-import Distribution.Simple.Utils (comparing)-import Hackage.Utils (mergeBy, MergeResult(..))--import Data.List (maximumBy)-import Data.Monoid (Monoid(mempty))-import qualified Data.Set as Set-import Data.Set (Set)-import Control.Exception (assert)--defaultResolver :: DependencyResolver a-defaultResolver = topDownResolver---for the brave: try the new topDownResolver, but only with --dry-run !!!---- | Global policy for the versions of all packages.----data PackagesVersionPreference =--     -- | Always prefer the latest version irrespective of any existing-     -- installed version.-     ---     -- * This is the standard policy for upgrade.-     ---     PreferAllLatest--     -- | Always prefer the installed versions over ones that would need to be-     -- installed. Secondarily, prefer latest versions (eg the latest installed-     -- version or if there are none then the latest available version).-   | PreferAllInstalled--     -- | Prefer the latest version for packages that are explicitly requested-     -- but prefers the installed version for any other packages.-     ---     -- * This is the standard policy for install.-     ---   | PreferLatestForSelected--resolveDependencies :: OS-                    -> Arch-                    -> CompilerId-                    -> Maybe (PackageIndex InstalledPackageInfo)-                    -> PackageIndex AvailablePackage-                    -> PackagesVersionPreference-                    -> [UnresolvedDependency]-                    -> Either String (InstallPlan a)-resolveDependencies os arch comp installed available pref deps =-  foldProgress (flip const) Left Right $-    resolveDependenciesWithProgress os arch comp installed available pref deps--resolveDependenciesWithProgress :: OS-                                -> Arch-                                -> CompilerId-                                -> Maybe (PackageIndex InstalledPackageInfo)-                                -> PackageIndex AvailablePackage-                                -> PackagesVersionPreference-                                -> [UnresolvedDependency]-                                -> Progress String String (InstallPlan a)-resolveDependenciesWithProgress os arch comp (Just installed) =-  dependencyResolver defaultResolver os arch comp installed--resolveDependenciesWithProgress os arch comp Nothing =-  dependencyResolver bogusResolver os arch comp mempty--hideBrokenPackages :: PackageFixedDeps p => PackageIndex p -> PackageIndex p-hideBrokenPackages index =-    check (null . PackageIndex.brokenPackages)-  . foldr (PackageIndex.deletePackageId . packageId) index-  . PackageIndex.reverseDependencyClosure index-  . map (packageId . fst)-  $ PackageIndex.brokenPackages index-  where-    check p x = assert (p x) x--hideBasePackage :: Package p => PackageIndex p -> PackageIndex p-hideBasePackage = PackageIndex.deletePackageName "base"-                . PackageIndex.deletePackageName "ghc-prim"--dependencyResolver-  :: DependencyResolver a-  -> OS -> Arch -> CompilerId-  -> PackageIndex InstalledPackageInfo-  -> PackageIndex AvailablePackage-  -> PackagesVersionPreference-  -> [UnresolvedDependency]-  -> Progress String String (InstallPlan a)-dependencyResolver resolver os arch comp installed available pref deps =-  let installed' = hideBrokenPackages installed-      available' = hideBasePackage available-   in fmap toPlan-    $ resolver os arch comp installed' available' preference deps--  where-    toPlan pkgs =-      case InstallPlan.new os arch 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 = interpretPackagesVersionPreference initialPkgNames pref-    initialPkgNames = Set.fromList-      [ name | UnresolvedDependency (Dependency name _) _ <- deps ]---- | Give an interpretation to the global 'PackagesVersionPreference' as---  specific per-package 'PackageVersionPreference'.----interpretPackagesVersionPreference :: Set PackageName-                                   -> PackagesVersionPreference-                                   -> (PackageName -> PackageVersionPreference)-interpretPackagesVersionPreference selected pref = case pref of-  PreferAllLatest         -> const PreferLatest-  PreferAllInstalled      -> const 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.----upgradableDependencies :: PackageIndex InstalledPackageInfo-                       -> PackageIndex AvailablePackage-                       -> [Dependency]-upgradableDependencies installed available =-  [ Dependency name (LaterVersion latestVersion)-    -- This is really quick (linear time). The trick is that we're doing a-    -- merge join of two tables. We can do it as a merge because they're in-    -- a comparable order because we're getting them from the package indexs.-  | InBoth latestInstalled allAvailable-      <- mergeBy (\a (b:_) -> packageName a `compare` packageName b)-                 [ maximumBy (comparing packageVersion) pkgs-                 | pkgs <- PackageIndex.allPackagesByName installed ]-                 (PackageIndex.allPackagesByName available)-  , let (PackageIdentifier name latestVersion) = packageId latestInstalled-  , any (\p -> packageVersion p > latestVersion) allAvailable ]
− Hackage/Dependency/Bogus.hs 
@@ -1,109 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Hackage.Dependency.Bogus--- Copyright   :  (c) David Himmelstrup 2005, Bjorn Bringert 2007---                    Duncan Coutts 2008--- License     :  BSD-like------ Maintainer  :  cabal-devel@haskell.org--- Stability   :  provisional--- Portability :  portable------ A dependency resolver for when we do not know what packages are installed.-------------------------------------------------------------------------------module Hackage.Dependency.Bogus (-    bogusResolver-  ) where--import Hackage.Types-         ( UnresolvedDependency(..), AvailablePackage(..)-         , ConfiguredPackage(..) )-import Hackage.Dependency.Types-         ( DependencyResolver, Progress(..) )-import qualified Hackage.InstallPlan as InstallPlan--import Distribution.Package-         ( PackageIdentifier(..), Dependency(..), Package(..) )-import Distribution.PackageDescription-         ( GenericPackageDescription(..), CondTree(..), FlagAssignment )-import Distribution.PackageDescription.Configuration-         ( finalizePackageDescription )-import qualified Distribution.Simple.PackageIndex as PackageIndex-import Distribution.Simple.PackageIndex (PackageIndex)-import Distribution.Version-         ( VersionRange(IntersectVersionRanges) )-import Distribution.Simple.Utils-         ( equating, comparing )-import Distribution.Text-         ( display )--import Data.List-         ( maximumBy, sortBy, groupBy )---- | This resolver thinks that every package is already installed.------ We need this for hugs and nhc98 which do not track installed packages.--- We just pretend that everything is installed and hope for the best.----bogusResolver :: DependencyResolver a-bogusResolver os arch comp _ available _ = resolveFromAvailable []-                                         . combineDependencies-  where-    resolveFromAvailable chosen [] = Done chosen-    resolveFromAvailable chosen (UnresolvedDependency dep flags : deps) =-      case latestAvailableSatisfying available dep of-        Nothing  -> Fail ("Unresolved dependency: " ++ display dep)-        Just apkg@(AvailablePackage _ pkg _) ->-          case finalizePackageDescription flags none os arch comp [] pkg of-            Right (_, flags') -> Step msg (resolveFromAvailable chosen' deps)-              where-                msg     = "selecting " ++ display (packageId pkg)-                cpkg    = fudgeChosenPackage apkg flags'-                chosen' = InstallPlan.Configured cpkg : chosen-            _ -> error "bogusResolver: impossible happened"-          where-            none :: Maybe (PackageIndex PackageIdentifier)-            none = Nothing--fudgeChosenPackage :: AvailablePackage -> FlagAssignment -> ConfiguredPackage-fudgeChosenPackage (AvailablePackage pkgid pkg source) flags =-  ConfiguredPackage (AvailablePackage pkgid (stripDependencies pkg) source)-                    flags ([] :: [PackageIdentifier]) -- empty list of deps-  where-    -- | Pretend that a package has no dependencies. Go through the-    -- 'GenericPackageDescription' and strip them all out.-    ---    stripDependencies :: GenericPackageDescription -> GenericPackageDescription-    stripDependencies gpkg = gpkg {-        condLibrary     = fmap stripDeps (condLibrary gpkg),-        condExecutables = [ (name, stripDeps tree)-                          | (name, tree) <- condExecutables gpkg ]-      }-    stripDeps :: CondTree v [Dependency] a -> CondTree v [Dependency] a-    stripDeps = mapTreeConstrs (const [])--    mapTreeConstrs :: (c -> c) -> CondTree v c a -> CondTree v c a-    mapTreeConstrs f (CondNode a c ifs) = CondNode a (f c) (map g ifs)-      where-        g (cnd, t, me) = (cnd, mapTreeConstrs f t, fmap (mapTreeConstrs f) me)--combineDependencies :: [UnresolvedDependency] -> [UnresolvedDependency]-combineDependencies = map combineGroup-                    . groupBy (equating depName)-                    . sortBy  (comparing depName)-  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---- | Gets the latest available package satisfying a dependency.-latestAvailableSatisfying :: PackageIndex AvailablePackage-                          -> Dependency-                          -> Maybe AvailablePackage-latestAvailableSatisfying index dep =-  case PackageIndex.lookupDependency index dep of-    []   -> Nothing-    pkgs -> Just (maximumBy (comparing (pkgVersion . packageId)) pkgs)
− Hackage/Dependency/Naive.hs 
@@ -1,180 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Hackage.Dependency--- Copyright   :  (c) David Himmelstrup 2005, Bjorn Bringert 2007,---                    Duncan Coutts 2008--- License     :  BSD-like------ Maintainer  :  cabal-devel@haskell.org--- Stability   :  provisional--- Portability :  portable------ A dependency resolver that is not very sophisticated.--- It often makes installation plans with inconsistent dependencies.-------------------------------------------------------------------------------module Hackage.Dependency.Naive (-    naiveResolver-  ) where--import Distribution.InstalledPackageInfo (InstalledPackageInfo_(package))-import qualified Distribution.Simple.PackageIndex as PackageIndex-import Distribution.Simple.PackageIndex (PackageIndex)-import Distribution.InstalledPackageInfo (InstalledPackageInfo)-import qualified Hackage.InstallPlan as InstallPlan-import Hackage.Types-         ( UnresolvedDependency(..), AvailablePackage(..)-         , ConfiguredPackage(..) )-import Hackage.Dependency.Types-         ( DependencyResolver, Progress(..) )-import Distribution.Package-         ( PackageIdentifier(..), Dependency(..), Package(..) )-import Distribution.PackageDescription-         ( PackageDescription(buildDepends), GenericPackageDescription-         , FlagAssignment )-import Distribution.PackageDescription.Configuration-    ( finalizePackageDescription)-import Distribution.Compiler-         ( CompilerId )-import Distribution.System-         ( OS, Arch )-import Distribution.Simple.Utils (comparing, intercalate)-import Hackage.Utils-         ( showDependencies )-import Distribution.Text-         ( display )--import Control.Monad (mplus)-import Data.List (maximumBy)-import Data.Maybe (fromMaybe)-import Data.Monoid (Monoid(mappend))--naiveResolver :: DependencyResolver a-naiveResolver os arch comp installed available _ deps =-  packagesToInstall installed-    [ resolveDependency os arch comp installed available dep flags-    | UnresolvedDependency dep flags <- deps]--resolveDependency :: OS-                  -> Arch-                  -> CompilerId-                  -> PackageIndex InstalledPackageInfo -- ^ Installed packages.-                  -> PackageIndex AvailablePackage -- ^ Installable packages-                  -> Dependency-                  -> FlagAssignment-                  -> ResolvedDependency-resolveDependency os arch comp installed available dep flags-    = fromMaybe (UnavailableDependency dep) $ resolveFromInstalled `mplus` resolveFromAvailable-  where-    resolveFromInstalled = fmap (InstalledDependency dep) $ latestInstalledSatisfying installed dep-    resolveFromAvailable =-        do pkg <- latestAvailableSatisfying available dep-           (deps, flags') <- getDependencies os arch comp installed available-                                             (packageDescription pkg) flags-           return $ AvailableDependency dep pkg flags'-              [ resolveDependency os arch comp installed available dep' []-              | dep' <- deps ]---- | Gets the latest installed package satisfying a dependency.-latestInstalledSatisfying :: PackageIndex InstalledPackageInfo -> Dependency -> Maybe PackageIdentifier-latestInstalledSatisfying  index dep =-  case PackageIndex.lookupDependency index dep of-    []   -> Nothing-    pkgs -> Just (maximumBy (comparing pkgVersion) (map package pkgs))---- | Gets the latest available package satisfying a dependency.-latestAvailableSatisfying :: PackageIndex AvailablePackage-                          -> Dependency-                          -> Maybe AvailablePackage-latestAvailableSatisfying index dep =-  case PackageIndex.lookupDependency index dep of-    []   -> Nothing-    pkgs -> Just (maximumBy (comparing (pkgVersion . packageId)) pkgs)---- | Gets the dependencies of an available package.-getDependencies :: OS-                -> Arch-                -> CompilerId-                -> PackageIndex InstalledPackageInfo -- ^ Installed packages.-                -> PackageIndex AvailablePackage -- ^ Available packages-                -> GenericPackageDescription-                -> FlagAssignment-                -> Maybe ([Dependency], FlagAssignment)-                   -- ^ If successful, this is the list of dependencies.-                   -- If flag assignment failed, this is the list of-                   -- missing dependencies.-getDependencies os arch comp installed available pkg flags-    = case e of-        Left  _missing      -> Nothing-        Right (desc,flags') -> Just (buildDepends desc, flags')-    where-      e = finalizePackageDescription-                flags-                (let --TODO: find a better way to do this:-                     flatten :: Package pkg => PackageIndex pkg-                                            -> PackageIndex PackageIdentifier-                     flatten = PackageIndex.fromList . map packageId-                             . PackageIndex.allPackages-                  in Just (flatten available `mappend` flatten installed))-                os arch comp [] pkg--packagesToInstall :: PackageIndex InstalledPackageInfo-                  -> [ResolvedDependency]-                  -> Progress String String [InstallPlan.PlanPackage a]-                     -- ^ Either a list of missing dependencies, or a graph-                     -- of packages to install, with their options.-packagesToInstall allInstalled deps0 =-  case unzipEithers (map getAvailable deps0) of-    ([], ok)     ->-      let selectedAvailable :: [InstallPlan.ConfiguredPackage]-          selectedAvailable = concatMap snd ok--          selectedInstalled :: [InstalledPackageInfo]-          selectedInstalled =-              either PackageIndex.allPackages-              (\borked -> error $ unlines-                [ "Package " ++ display (packageId pkg)-                  ++ " depends on the following packages which are missing from the plan "-                  ++ intercalate ", " (map display missingDeps)-                | (pkg, missingDeps) <- borked ])-            $ PackageIndex.dependencyClosure-                allInstalled-                (getInstalled deps0)--       in Done $ map InstallPlan.Configured selectedAvailable-              ++ map InstallPlan.PreExisting selectedInstalled--    (missing, _) -> Fail $ "Unresolved dependencies: "-                        ++ showDependencies (concat missing)--  where-    getAvailable :: ResolvedDependency-                  -> Either [Dependency]-                            (PackageIdentifier, [InstallPlan.ConfiguredPackage])-    getAvailable (InstalledDependency _ pkgid    )-      = Right (pkgid, [])-    getAvailable (AvailableDependency _ pkg flags deps) =-      case unzipEithers (map getAvailable deps) of-        ([], ok)     -> let resolved = InstallPlan.ConfiguredPackage pkg flags-                                         [ pkgid | (pkgid, _) <- ok ]-                                     : concatMap snd ok-                         in Right (packageId pkg, resolved)-        (missing, _) -> Left (concat missing)-    getAvailable (UnavailableDependency dep) = Left [dep]--    getInstalled :: [ResolvedDependency] -> [PackageIdentifier]-    getInstalled [] = []-    getInstalled (dep:deps) = case dep of-      InstalledDependency _ pkgid     -> pkgid : getInstalled deps-      AvailableDependency _ _ _ deps' ->         getInstalled (deps'++deps)-      UnavailableDependency _         ->         getInstalled deps---- TODO: kill this data type-data ResolvedDependency-       = InstalledDependency Dependency PackageIdentifier-       | AvailableDependency Dependency AvailablePackage FlagAssignment [ResolvedDependency]-       | UnavailableDependency Dependency-       deriving (Show)--unzipEithers :: [Either a b] -> ([a], [b])-unzipEithers = foldr (flip consEither) ([], [])-  where consEither ~(ls,rs) = either (\l -> (l:ls,rs)) (\r -> (ls,r:rs))
− Hackage/Dependency/TopDown.hs 
@@ -1,598 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Hackage.Dependency.Types--- Copyright   :  (c) Duncan Coutts 2008--- License     :  BSD-like------ Maintainer  :  cabal-devel@haskell.org--- Stability   :  provisional--- Portability :  portable------ Common types for dependency resolution.-------------------------------------------------------------------------------module Hackage.Dependency.TopDown (-    topDownResolver-  ) where--import Hackage.Dependency.TopDown.Types-import qualified Hackage.Dependency.TopDown.Constraints as Constraints-import Hackage.Dependency.TopDown.Constraints-         ( Satisfiable(..) )-import qualified Hackage.InstallPlan as InstallPlan-import Hackage.InstallPlan-         ( PlanPackage(..) )-import Hackage.Types-         ( UnresolvedDependency(..), AvailablePackage(..)-         , ConfiguredPackage(..) )-import Hackage.Dependency.Types-         ( PackageName, DependencyResolver, PackageVersionPreference(..)-         , Progress(..), foldProgress )--import qualified Distribution.Simple.PackageIndex as PackageIndex-import Distribution.Simple.PackageIndex (PackageIndex)-import Distribution.InstalledPackageInfo-         ( InstalledPackageInfo )-import Distribution.Package-         ( PackageIdentifier, Package(packageId), packageVersion, packageName-         , Dependency(Dependency), thisPackageVersion, notThisPackageVersion-         , PackageFixedDeps(depends) )-import Distribution.PackageDescription-         ( PackageDescription(buildDepends) )-import Distribution.PackageDescription.Configuration-         ( finalizePackageDescription, flattenPackageDescription )-import Distribution.Compiler-         ( CompilerId )-import Distribution.System-         ( OS, Arch )-import Distribution.Simple.Utils-         ( equating, comparing )-import Distribution.Text-         ( display )--import Data.List-         ( foldl', maximumBy, minimumBy, deleteBy, nub, sort )-import Data.Maybe-         ( fromJust, fromMaybe )-import Data.Monoid-         ( Monoid(mempty) )-import Control.Monad-         ( guard )-import qualified Data.Set as Set-import Data.Set (Set)-import qualified Data.Map as Map-import qualified Data.Graph as Graph-import qualified Data.Array as Array---- --------------------------------------------------------------- * Search state types--- --------------------------------------------------------------type Constraints  = Constraints.Constraints-                      InstalledPackage UnconfiguredPackage ExclusionReason-type SelectedPackages = PackageIndex SelectedPackage---- --------------------------------------------------------------- * The search tree type--- --------------------------------------------------------------data SearchSpace inherited pkg-   = ChoiceNode inherited [[(pkg, SearchSpace inherited pkg)]]-   | Failure Failure---- --------------------------------------------------------------- * Traverse a search tree--- --------------------------------------------------------------explore :: (PackageName -> PackageVersionPreference)-        -> SearchSpace a SelectablePackage-        -> Progress Log Failure a--explore _    (Failure failure)      = Fail failure-explore _explore    (ChoiceNode result []) = Done result-explore pref (ChoiceNode _ choices) =-  case [ choice | [choice] <- choices ] of-    ((pkg, node'):_) -> Step (Select pkg [])    (explore pref node')-    []               -> seq pkgs' -- avoid retaining defaultChoice-                      $ Step (Select pkg pkgs') (explore pref node')-      where-        choice       = minimumBy (comparing topSortNumber) choices-        pkgname      = packageName . fst . head $ choice-        (pkg, node') = maximumBy (bestByPref pkgname) choice-        pkgs' = deleteBy (equating packageId) pkg (map fst choice)--  where-    topSortNumber choice = case fst (head choice) of-      InstalledOnly           (InstalledPackage    _ i _) -> i-      AvailableOnly           (UnconfiguredPackage _ i _) -> i-      InstalledAndAvailable _ (UnconfiguredPackage _ i _) -> i--    bestByPref pkgname = case pref pkgname of-      PreferLatest    -> comparing (\(p,_) ->                 packageId p)-      PreferInstalled -> comparing (\(p,_) -> (isInstalled p, packageId p))-      where isInstalled (AvailableOnly _) = False-            isInstalled _                 = True---- --------------------------------------------------------------- * Generate a search tree--- --------------------------------------------------------------type ConfigurePackage = PackageIndex SelectablePackage-                     -> SelectablePackage-                     -> Either [Dependency] SelectedPackage--searchSpace :: ConfigurePackage-            -> Constraints-            -> SelectedPackages-            -> Set PackageName-            -> SearchSpace (SelectedPackages, Constraints) SelectablePackage-searchSpace configure constraints selected next =-  ChoiceNode (selected, constraints)-    [ [ (pkg, select name pkg)-      | pkg <- PackageIndex.lookupPackageName available name ]-    | name <- Set.elems next ]-  where-    available = Constraints.choices constraints--    select name pkg = case configure available pkg of-      Left missing -> Failure $ ConfigureFailed pkg-                        [ (dep, Constraints.conflicting constraints dep)-                        | dep <- missing ]-      Right pkg' ->-        let selected' = PackageIndex.insert pkg' selected-            newPkgs   = [ name'-                        | dep <- packageConstraints pkg'-                        , let (Dependency name' _) = untagDependency dep-                        , null (PackageIndex.lookupPackageName selected' name') ]-            newDeps   = packageConstraints pkg'-            next'     = Set.delete name-                      $ foldl' (flip Set.insert) next newPkgs-         in case constrainDeps pkg' newDeps constraints of-              Left failure       -> Failure failure-              Right constraints' -> searchSpace configure-                                      constraints' selected' next'--packageConstraints :: SelectedPackage -> [TaggedDependency]-packageConstraints = either installedConstraints availableConstraints-                   . preferAvailable-  where-    preferAvailable (InstalledOnly           pkg) = Left pkg-    preferAvailable (AvailableOnly           pkg) = Right pkg-    preferAvailable (InstalledAndAvailable _ pkg) = Right pkg-    installedConstraints (InstalledPackage      _ _ deps) =-      [ TaggedDependency InstalledConstraint (thisPackageVersion dep)-      | dep <- deps ]-    availableConstraints (SemiConfiguredPackage _ _ deps) =-      [ TaggedDependency NoInstalledConstraint dep | dep <- deps ]--constrainDeps :: SelectedPackage -> [TaggedDependency] -> Constraints-              -> Either Failure Constraints-constrainDeps pkg []         cs =-  case addPackageSelectConstraint (packageId pkg) cs of-    Satisfiable cs' -> Right cs'-    _               -> impossible-constrainDeps pkg (dep:deps) cs =-  case addPackageDependencyConstraint (packageId pkg) dep cs of-    Satisfiable cs' -> constrainDeps pkg deps cs'-    Unsatisfiable   -> impossible-    ConflictsWith conflicts ->-      Left (DependencyConflict pkg dep conflicts)---- --------------------------------------------------------------- * The main algorithm--- --------------------------------------------------------------search :: ConfigurePackage-       -> (PackageName -> PackageVersionPreference)-       -> Constraints-       -> Set PackageName-       -> Progress Log Failure (SelectedPackages, Constraints)-search configure pref constraints =-  explore pref . searchSpace configure constraints mempty---- --------------------------------------------------------------- * The top level resolver--- ---------------------------------------------------------------- | The main exported resolver, with string logging and failure types to fit--- the standard 'DependencyResolver' interface.----topDownResolver :: DependencyResolver a-topDownResolver = ((((((mapMessages .).).).).).) . topDownResolver'-  where-    mapMessages :: Progress Log Failure a -> Progress String String a-    mapMessages = foldProgress (Step . showLog) (Fail . showFailure) Done---- | The native resolver with detailed structured logging and failure types.----topDownResolver' :: OS -> Arch -> CompilerId-                 -> PackageIndex InstalledPackageInfo-                 -> PackageIndex AvailablePackage-                 -> (PackageName -> PackageVersionPreference)-                 -> [UnresolvedDependency]-                 -> Progress Log Failure [PlanPackage a]-topDownResolver' os arch comp installed available pref deps =-      fmap (uncurry finalise)-    . (\cs -> search configure pref cs initialPkgNames)-  =<< constrainTopLevelDeps deps constraints--  where-    configure   = configurePackage os arch comp-    constraints = Constraints.empty-                    (annotateInstalledPackages      topSortNumber installed')-                    (annotateAvailablePackages deps topSortNumber available')-    (installed', available') = selectNeededSubset installed available-                                                  initialPkgNames-    topSortNumber = topologicalSortNumbering installed' available'--    initialDeps     = [ dep  | UnresolvedDependency dep _ <- deps ]-    initialPkgNames = Set.fromList [ name | Dependency name _ <- initialDeps ]--    finalise selected = PackageIndex.allPackages-                      . improvePlan installed'-                      . PackageIndex.fromList-                      . finaliseSelectedPackages selected--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)--configurePackage :: OS -> Arch -> CompilerId -> ConfigurePackage-configurePackage os arch comp available spkg = case spkg of-  InstalledOnly         ipkg      -> Right (InstalledOnly ipkg)-  AvailableOnly              apkg -> fmap AvailableOnly (configure apkg)-  InstalledAndAvailable ipkg apkg -> fmap (InstalledAndAvailable ipkg)-                                          (configure apkg)-  where-  configure (UnconfiguredPackage apkg@(AvailablePackage _ p _) _ flags) =-    case finalizePackageDescription flags (Just available) os arch comp [] p of-      Left missing        -> Left missing-      Right (pkg, flags') -> Right $-        SemiConfiguredPackage apkg flags' (buildDepends pkg)---- | Annotate each installed packages with its set of transative dependencies--- and its topological sort number.----annotateInstalledPackages :: (PackageName -> TopologicalSortNumber)-                          -> PackageIndex InstalledPackageInfo-                          -> PackageIndex InstalledPackage-annotateInstalledPackages dfsNumber installed = PackageIndex.fromList-  [ InstalledPackage pkg (dfsNumber (packageName pkg)) (transitiveDepends pkg)-  | pkg <- PackageIndex.allPackages installed ]-  where-    transitiveDepends :: InstalledPackageInfo -> [PackageIdentifier]-    transitiveDepends = map toPkgid . tail . Graph.reachable graph-                      . fromJust . toVertex . packageId-    (graph, toPkgid, toVertex) = PackageIndex.dependencyGraph installed----- | Annotate each available packages with its topological sort number and any--- user-supplied partial flag assignment.----annotateAvailablePackages :: [UnresolvedDependency]-                          -> (PackageName -> TopologicalSortNumber)-                          -> PackageIndex AvailablePackage-                          -> PackageIndex UnconfiguredPackage-annotateAvailablePackages deps dfsNumber available = PackageIndex.fromList-  [ UnconfiguredPackage pkg (dfsNumber name) (flagsFor name)-  | pkg <- PackageIndex.allPackages available-  , let name = packageName pkg ]-  where-    flagsFor = fromMaybe [] . flip Map.lookup flagsMap-    flagsMap = Map.fromList-      [ (name, flags)-      | UnresolvedDependency (Dependency name _) flags <- deps ]---- | 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--- to make decisions about packages higer in the dep graph first since they--- place constraints on packages lower in the dep graph.------ To pick them in that order we annotate each package with its topological--- sort number. So if package A depends on package B then package A will have--- a lower topological sort number than B and we'll make a choice about which--- version of A to pick before we make a choice about B (unless there is only--- one possible choice for B in which case we pick that immediately).------ To construct these topological sort numbers we combine and flatten the--- installed and available package sets. We consider only dependencies between--- named packages, not including versions and for not-yet-configured packages--- we look at all the possible dependencies, not just those under any single--- flag assignment. This means we can actually get impossible combinations of--- edges and even cycles, but that doesn't really matter here, it's only a--- heuristic.----topologicalSortNumbering :: PackageIndex InstalledPackageInfo-                         -> PackageIndex AvailablePackage-                         -> (PackageName -> TopologicalSortNumber)-topologicalSortNumbering installed available =-    \pkgname -> let Just vertex = toVertex pkgname-                 in topologicalSortNumbers Array.! vertex-  where-    topologicalSortNumbers = Array.array (Array.bounds graph)-                                         (zip (Graph.topSort graph) [0..])-    (graph, _, toVertex)   = Graph.graphFromEdges $-         [ ((), packageName pkg, nub deps)-         | pkgs@(pkg:_) <- PackageIndex.allPackagesByName installed-         , let deps = [ packageName dep-                      | pkg' <- pkgs-                      , dep  <- depends pkg' ] ]-      ++ [ ((), packageName pkg, nub deps)-         | pkgs@(pkg:_) <- PackageIndex.allPackagesByName available-         , let deps = [ depName-                      | AvailablePackage _ pkg' _ <- pkgs-                      , Dependency depName _ <--                          buildDepends (flattenPackageDescription pkg') ] ]---- | We don't need the entire index (which is rather large and costly if we--- force it by examining the whole thing). So trace out the maximul subset of--- each index that we could possibly ever need. Do this by flattening packages--- and looking at the names of all possible dependencies.----selectNeededSubset :: PackageIndex InstalledPackageInfo-                   -> PackageIndex AvailablePackage-                   -> Set PackageName-                   -> (PackageIndex InstalledPackageInfo-                      ,PackageIndex AvailablePackage)-selectNeededSubset installed available = select mempty mempty-  where-    select :: PackageIndex InstalledPackageInfo-           -> PackageIndex AvailablePackage-           -> Set PackageName-           -> (PackageIndex InstalledPackageInfo-              ,PackageIndex AvailablePackage)-    select installed' available' remaining-      | Set.null remaining = (installed', available')-      | otherwise = select installed'' available'' remaining''-      where-        (next, remaining') = Set.deleteFindMin remaining-        moreInstalled = PackageIndex.lookupPackageName installed next-        moreAvailable = PackageIndex.lookupPackageName available next-        moreRemaining = nub-                      $ [ packageName dep-                        | pkg <- moreInstalled-                        , dep <- depends pkg ]-                     ++ [ name-                        | AvailablePackage _ pkg _ <- moreAvailable-                        , Dependency name _ <--                            buildDepends (flattenPackageDescription pkg) ]-        installed''   = foldr PackageIndex.insert installed' moreInstalled-        available''   = foldr PackageIndex.insert available' moreAvailable-        remaining''   = foldr          Set.insert remaining' moreRemaining---- --------------------------------------------------------------- * Post processing the solution--- --------------------------------------------------------------finaliseSelectedPackages :: SelectedPackages-                         -> Constraints-                         -> [PlanPackage a]-finaliseSelectedPackages selected constraints =-  map finaliseSelected (PackageIndex.allPackages selected)-  where-    remainingChoices = Constraints.choices constraints-    finaliseSelected (InstalledOnly         ipkg     ) = finaliseInstalled ipkg-    finaliseSelected (AvailableOnly              apkg) = finaliseAvailable apkg-    finaliseSelected (InstalledAndAvailable ipkg apkg) =-      case PackageIndex.lookupPackageId remainingChoices (packageId ipkg) of-        Nothing                          -> impossible --picked package not in constraints-        Just (AvailableOnly _)           -> impossible --to constrain to avail only-        Just (InstalledOnly _)           -> finaliseInstalled ipkg-        Just (InstalledAndAvailable _ _) -> finaliseAvailable apkg--    finaliseInstalled (InstalledPackage pkg _ _) = InstallPlan.PreExisting pkg-    finaliseAvailable (SemiConfiguredPackage pkg flags deps) =-      InstallPlan.Configured (ConfiguredPackage pkg flags deps')-      where deps' = [ packageId pkg'-                    | dep <- deps-                    , let pkg' = case PackageIndex.lookupDependency selected dep of-                                   [pkg''] -> pkg''-                                   _ -> impossible ]---- | Improve an existing installation plan by, where possible, swapping--- packages we plan to install with ones that are already installed.----improvePlan :: PackageIndex InstalledPackageInfo-            -> PackageIndex (PlanPackage a)-            -> PackageIndex (PlanPackage a)-improvePlan installed selected = foldl' improve selected-                               $ reverseTopologicalOrder selected-  where-    improve selected' = maybe selected' (flip PackageIndex.insert selected')-                      . improvePkg selected'--    -- 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-      ipkg            <- PackageIndex.lookupPackageId installed pkgid-      guard $ sort (depends pkg) == nub (sort (depends ipkg))-      guard $ all (isInstalled selected') (depends pkg)-      return (PreExisting ipkg)--    isInstalled selected' pkgid =-      case PackageIndex.lookupPackageId selected' pkgid of-        Just (PreExisting _) -> True-        _                    -> False--    reverseTopologicalOrder :: PackageFixedDeps pkg => PackageIndex pkg-                            -> [PackageIdentifier]-    reverseTopologicalOrder index = map toPkgId-                                  . Graph.topSort-                                  . Graph.transposeG-                                  $ graph-      where (graph, toPkgId, _) = PackageIndex.dependencyGraph index---- --------------------------------------------------------------- * Adding and recording constraints--- --------------------------------------------------------------addPackageSelectConstraint :: PackageIdentifier -> Constraints-                           -> Satisfiable Constraints ExclusionReason-addPackageSelectConstraint pkgid constraints =-  Constraints.constrain dep reason constraints-  where-    dep    = TaggedDependency NoInstalledConstraint (thisPackageVersion pkgid)-    reason = SelectedOther pkgid--addPackageExcludeConstraint :: PackageIdentifier -> Constraints-                     -> Satisfiable Constraints ExclusionReason-addPackageExcludeConstraint pkgid constraints =-  Constraints.constrain dep reason constraints-  where-    dep    = TaggedDependency NoInstalledConstraint-               (notThisPackageVersion pkgid)-    reason = ExcludedByConfigureFail--addPackageDependencyConstraint :: PackageIdentifier -> TaggedDependency -> Constraints-                               -> Satisfiable Constraints ExclusionReason-addPackageDependencyConstraint pkgid dep constraints =-  Constraints.constrain dep reason constraints-  where-    reason = ExcludedByPackageDependency pkgid dep--addTopLevelDependencyConstraint :: Dependency -> Constraints-                                -> Satisfiable Constraints ExclusionReason-addTopLevelDependencyConstraint dep constraints =-  Constraints.constrain taggedDep reason constraints-  where-    taggedDep = TaggedDependency NoInstalledConstraint dep-    reason = ExcludedByTopLevelDependency dep---- --------------------------------------------------------------- * Reasons for constraints--- ---------------------------------------------------------------- | For every constraint we record we also record the reason that constraint--- is needed. So if we end up failing due to conflicting constraints then we--- can give an explnanation as to what was conflicting and why.----data ExclusionReason =--     -- | We selected this other version of the package. That means we exclude-     -- all the other versions.-     SelectedOther PackageIdentifier--     -- | We excluded this version of the package because it failed to-     -- configure probably because of unsatisfiable deps.-   | ExcludedByConfigureFail--     -- | We excluded this version of the package because another package that-     -- we selected imposed a dependency which this package did not satisfy.-   | ExcludedByPackageDependency PackageIdentifier TaggedDependency--     -- | We excluded this version of the package because it did not satisfy-     -- a dependency given as an original top level input.-     ---   | ExcludedByTopLevelDependency Dependency---- | Given an excluded package and the reason it was excluded, produce a human--- readable explanation.----showExclusionReason :: PackageIdentifier -> ExclusionReason -> String-showExclusionReason pkgid (SelectedOther pkgid') =-  display pkgid ++ " was excluded because " ++-  display pkgid' ++ " was selected instead"-showExclusionReason pkgid ExcludedByConfigureFail =-  display pkgid ++ " was excluded because it could not be configured"-showExclusionReason pkgid (ExcludedByPackageDependency pkgid' dep) =-  display pkgid ++ " was excluded because " ++-  display pkgid' ++ " requires " ++ display (untagDependency dep)-showExclusionReason pkgid (ExcludedByTopLevelDependency dep) =-  display pkgid ++ " was excluded because of the top level dependency " ++-  display dep----- --------------------------------------------------------------- * Logging progress and failures--- --------------------------------------------------------------data Log = Select SelectablePackage [SelectablePackage]-data Failure-   = ConfigureFailed-       SelectablePackage-       [(Dependency, [(PackageIdentifier, [ExclusionReason])])]-   | DependencyConflict-       SelectedPackage TaggedDependency-       [(PackageIdentifier, [ExclusionReason])]-   | TopLevelDependencyConflict-       Dependency-       [(PackageIdentifier, [ExclusionReason])]-   | TopLevelDependencyUnsatisfiable-       Dependency--showLog :: Log -> String-showLog (Select selected discarded) =-     "selecting " ++ displayPkg selected ++ " " ++ kind selected-  ++ case discarded of-       []  -> ""-       [d] -> " and discarding version " ++ display (packageVersion d)-       _   -> " and discarding versions "-           ++ listOf (display . packageVersion) discarded-  where-    kind (InstalledOnly _)           = "(installed)"-    kind (AvailableOnly _)           = "(hackage)"-    kind (InstalledAndAvailable _ _) = "(installed or hackage)"--showFailure :: Failure -> String-showFailure (ConfigureFailed pkg missingDeps) =-     "cannot configure " ++ displayPkg pkg ++ ". It requires "-  ++ listOf (display . fst) missingDeps-  ++ '\n' : unlines (map (uncurry whyNot) missingDeps)--  where-    whyNot (Dependency name ver) [] =-         "There is no available version of " ++ name-      ++ " that satisfies " ++ display ver--    whyNot dep conflicts =-         "For the dependency on " ++ display dep-      ++ " there are these packages: " ++ listOf display pkgs-      ++ ". However none of them are available.\n"-      ++ unlines [ showExclusionReason (packageId pkg') reason-                 | (pkg', reasons) <- conflicts, reason <- reasons ]--      where pkgs = map fst conflicts--showFailure (DependencyConflict pkg (TaggedDependency _ dep) conflicts) =-     "dependencies conflict: "-  ++ displayPkg pkg ++ " requires " ++ display dep ++ " however\n"-  ++ unlines [ showExclusionReason (packageId pkg') reason-             | (pkg', reasons) <- conflicts, reason <- reasons ]--showFailure (TopLevelDependencyConflict dep conflicts) =-     "dependencies conflict: "-  ++ "top level dependency " ++ display dep ++ " however\n"-  ++ unlines [ showExclusionReason (packageId pkg') reason-             | (pkg', reasons) <- conflicts, reason <- reasons ]--showFailure (TopLevelDependencyUnsatisfiable (Dependency name ver)) =-     "There is no available version of " ++ name-      ++ " that satisfies " ++ display ver---- --------------------------------------------------------------- * Utils--- --------------------------------------------------------------impossible :: a-impossible = internalError "impossible"--internalError :: String -> a-internalError msg = error $ "internal error: " ++ msg--displayPkg :: Package pkg => pkg -> String-displayPkg = display . packageId--listOf :: (a -> String) -> [a] -> String-listOf _    []   = []-listOf disp [x0] = disp x0-listOf disp (x0:x1:xs) = disp x0 ++ go x1 xs-  where go x []       = " and " ++ disp x-        go x (x':xs') = ", " ++ disp x ++ go x' xs'
− Hackage/Dependency/TopDown/Constraints.hs 
@@ -1,244 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Hackage.Dependency.TopDown.Constraints--- Copyright   :  (c) Duncan Coutts 2008--- License     :  BSD-like------ Maintainer  :  duncan@haskell.org--- Stability   :  provisional--- Portability :  portable------ A set of satisfiable dependencies (package version constraints).-------------------------------------------------------------------------------module Hackage.Dependency.TopDown.Constraints (-  Constraints,-  empty,-  choices,-  -  constrain,-  Satisfiable(..),-  conflicting,-  ) where--import Hackage.Dependency.TopDown.Types-import qualified Distribution.Simple.PackageIndex as PackageIndex-import Distribution.Simple.PackageIndex (PackageIndex)-import Distribution.Package-         ( PackageIdentifier, Package(packageId), packageVersion, packageName-         , Dependency(Dependency) )-import Distribution.Version-         ( withinRange )-import Distribution.Simple.Utils-         ( comparing )-import Hackage.Utils-         ( mergeBy, MergeResult(..) )--import Data.List-         ( foldl', sortBy )-import Data.Monoid-         ( Monoid(mempty) )-import Control.Exception-         ( assert )---- | A set of constraints on package versions. For each package name we record--- what other packages depends on it and what constraints they impose on the--- version of the package.----data (Package installed, Package available)-  => Constraints installed available reason-   = Constraints--       -- Remaining available choices-       (PackageIndex (InstalledOrAvailable installed available))-       -       -- Choices that we have excluded for some reason-       -- usually by applying constraints-       (PackageIndex (ExcludedPackage PackageIdentifier reason))--data ExcludedPackage pkg reason-   = ExcludedPackage pkg [reason] -- reasons for excluding just the available-                         [reason] -- reasons for excluding installed and avail--instance Package pkg => Package (ExcludedPackage pkg reason) where-  packageId (ExcludedPackage p _ _) = packageId p---- | The intersection between the two indexes is empty-invariant :: (Package installed, Package available)-          => Constraints installed available a -> Bool-invariant (Constraints available excluded) =-  all (uncurry ok) [ (a, e) | InBoth a e <- merged ]-  where-    merged = mergeBy (\a b -> packageId a `compare` packageId b)-                     (PackageIndex.allPackages available)-                     (PackageIndex.allPackages excluded)-    ok (InstalledOnly _) (ExcludedPackage _ _ []) = True-    ok _                 _                        = 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') =-     invariant constraints && invariant constraints'-  && null availableGained  && null excludedLost-  && map packageId availableLost == map packageId excludedGained--  where-    availableLost   = foldr lost [] availableChange where-      lost (OnlyInLeft  pkg)          rest = pkg : rest-      lost (InBoth (InstalledAndAvailable _ pkg)-                   (InstalledOnly _)) rest = AvailableOnly pkg : rest-      lost _                          rest = rest-    availableGained = [ pkg | OnlyInRight pkg <- availableChange ]-    excludedLost    = [ pkg | OnlyInLeft  pkg <- excludedChange  ]-    excludedGained  = [ pkg | OnlyInRight pkg <- excludedChange  ]-    availableChange = mergeBy (\a b -> packageId a `compare` packageId b)-                              (allPackagesInOrder available)-                              (allPackagesInOrder available')-    excludedChange  = mergeBy (\a b -> packageId a `compare` packageId b)-                              (allPackagesInOrder excluded)-                              (allPackagesInOrder excluded')----FIXME: PackageIndex.allPackages returns in sorted order case-insensitively--- but that's no good for our merge which uses Ord-allPackagesInOrder :: Package pkg => PackageIndex pkg -> [pkg]-allPackagesInOrder index = -    concatMap snd-  . sortBy (comparing fst)-  $ [ (packageName pkg, grp)-    | grp@(pkg:_) <- PackageIndex.allPackagesByName index ]---- | We construct 'Constraints' with an initial 'PackageIndex' of all the--- packages available.----empty :: (Package installed, Package available)-      => PackageIndex installed-      -> PackageIndex available-      -> Constraints installed available reason-empty installed available = Constraints pkgs mempty-  where-    pkgs = PackageIndex.fromList-         . map toInstalledOrAvailable-         $ mergeBy (\a b -> packageId a `compare` packageId b)-                   (allPackagesInOrder installed)-                   (allPackagesInOrder available) -    toInstalledOrAvailable (OnlyInLeft  i  ) = InstalledOnly         i-    toInstalledOrAvailable (OnlyInRight   a) = AvailableOnly           a-    toInstalledOrAvailable (InBoth      i a) = InstalledAndAvailable i a ---- | The package choices that are still available.----choices :: (Package installed, Package available)-        => Constraints installed available reason-        -> PackageIndex (InstalledOrAvailable installed available)-choices (Constraints available _) = available--data Satisfiable a reason-       = Satisfiable a-       | Unsatisfiable-       | ConflictsWith [(PackageIdentifier, [reason])]--constrain :: (Package installed, Package available)-          => TaggedDependency-          -> reason-          -> Constraints installed available reason-          -> Satisfiable (Constraints installed available reason) reason-constrain (TaggedDependency installedConstraint (Dependency name versionRange))-          reason constraints@(Constraints available excluded)--  | not anyRemaining-  = if null conflicts then Unsatisfiable-                      else ConflictsWith conflicts--  | otherwise -  = let constraints' = Constraints available' excluded'-     in assert (constraints `transitionsTo` constraints') $-        Satisfiable constraints'--  where-  -- This tells us if any packages would remain at all for this package name if-  -- we applied this constraint. This amounts to checking if any package-  -- satisfies the given constraint, including version range and installation-  -- status.-  ---  anyRemaining = any satisfiesConstraint availableChoices--  conflicts = [ (packageId pkg, reasonsAvail ++ reasonsAll)-              | ExcludedPackage pkg reasonsAvail reasonsAll <- excludedChoices-              , satisfiesVersionConstraint pkg ]--  -- Applying this constraint may involve deleting some choices for this-  -- package name, or restricting which install states are available.-  available' = updateAvailable available-  updateAvailable = flip (foldl' (flip update)) availableChoices where-    update pkg | not (satisfiesVersionConstraint pkg)-               = PackageIndex.deletePackageId (packageId pkg)-    update _   | installedConstraint == NoInstalledConstraint-               = id-    update pkg = case pkg of-      InstalledOnly         _   -> id-      AvailableOnly           _ -> error "impossible" -- PackageIndex.deletePackageId (packageId pkg)-      InstalledAndAvailable i _ -> PackageIndex.insert (InstalledOnly i)--  -- Applying the constraint means adding exclusions for the packages that-  -- we're just freshly excluding, ie the ones we're removing from available.-  excluded' = addNewExcluded . addOldExcluded $ excluded-  addNewExcluded index = foldl' (flip exclude) index availableChoices where-    exclude pkg-      | not (satisfiesVersionConstraint pkg)-      = PackageIndex.insert $ ExcludedPackage pkgid [] [reason]-      | installedConstraint == NoInstalledConstraint-      = id-      | otherwise = case pkg of-      InstalledOnly         _   -> id-      AvailableOnly           _ -> PackageIndex.insert-                                     (ExcludedPackage pkgid [reason] [])-      InstalledAndAvailable _ _ ->-        case PackageIndex.lookupPackageId excluded pkgid of-          Just (ExcludedPackage _ avail both) ->-            PackageIndex.insert (ExcludedPackage pkgid (reason:avail) both)-          Nothing ->-            PackageIndex.insert (ExcludedPackage pkgid [reason] [])-      where pkgid = packageId pkg--  -- Additionally we have to add extra exclusions for any already-excluded-  -- packages that happen to be covered by the (inverse of the) constraint.-  addOldExcluded = flip (foldl' (flip exclude)) excludedChoices where-    exclude (ExcludedPackage pkgid avail both)-      -- if it doesn't satisfy the version constraint then we exclude the-      -- package as a whole, the available or the installed instances or both.-      | not (satisfiesVersionConstraint pkgid)-      = PackageIndex.insert (ExcludedPackage pkgid avail (reason:both))-      -- if on the other hand it does satisfy the constraint and we were also-      -- constraining to just the installed version then we exclude just the-      -- available instance.-      | installedConstraint == InstalledConstraint-      = PackageIndex.insert (ExcludedPackage pkgid (reason:avail) both)-      | otherwise = id--  -- util definitions-  availableChoices = PackageIndex.lookupPackageName available name-  excludedChoices  = PackageIndex.lookupPackageName excluded  name--  satisfiesConstraint pkg = satisfiesVersionConstraint pkg-                         && satisfiesInstallStateConstraint pkg--  satisfiesVersionConstraint pkg =-    packageVersion pkg `withinRange` versionRange--  satisfiesInstallStateConstraint = case installedConstraint of-    NoInstalledConstraint -> \_   -> True-    InstalledConstraint   -> \pkg -> case pkg of-      AvailableOnly _             -> False-      _                           -> True--conflicting :: (Package installed, Package available)-            => Constraints installed available reason-            -> Dependency-            -> [(PackageIdentifier, [reason])]-conflicting (Constraints _ excluded) dep =-  [ (pkgid, reasonsAvail ++ reasonsAll) --TODO-  | ExcludedPackage pkgid reasonsAvail reasonsAll <--      PackageIndex.lookupDependency excluded dep ]
− Hackage/Dependency/TopDown/Types.hs 
@@ -1,90 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Hackage.Dependency.TopDown.Types--- Copyright   :  (c) Duncan Coutts 2008--- License     :  BSD-like------ Maintainer  :  cabal-devel@haskell.org--- Stability   :  provisional--- Portability :  portable------ Types for the top-down dependency resolver.-------------------------------------------------------------------------------module Hackage.Dependency.TopDown.Types where--import Hackage.Types-         ( AvailablePackage(..) )--import Distribution.InstalledPackageInfo (InstalledPackageInfo)-import Distribution.Package-         ( PackageIdentifier, Dependency, Package(packageId) )-import Distribution.PackageDescription-         ( FlagAssignment )---- --------------------------------------------------------------- * The various kinds of packages--- --------------------------------------------------------------type SelectablePackage-   = InstalledOrAvailable InstalledPackage UnconfiguredPackage--type SelectedPackage-   = InstalledOrAvailable InstalledPackage SemiConfiguredPackage--data InstalledOrAvailable installed available-   = InstalledOnly         installed-   | AvailableOnly                   available-   | InstalledAndAvailable installed available--type TopologicalSortNumber = Int--data InstalledPackage-   = InstalledPackage-       InstalledPackageInfo-       !TopologicalSortNumber-       [PackageIdentifier]--data UnconfiguredPackage-   = UnconfiguredPackage-       AvailablePackage-       !TopologicalSortNumber-       FlagAssignment--data SemiConfiguredPackage-   = SemiConfiguredPackage-       AvailablePackage  -- package info-       FlagAssignment    -- total flag assignment for the package-       [Dependency]      -- dependencies we end up with when we apply-                         -- the flag assignment--instance Package InstalledPackage where-  packageId (InstalledPackage p _ _) = packageId p--instance Package UnconfiguredPackage where-  packageId (UnconfiguredPackage p _ _) = packageId p--instance Package SemiConfiguredPackage where-  packageId (SemiConfiguredPackage p _ _) = packageId p--instance (Package installed, Package available)-      => Package (InstalledOrAvailable installed available) where-  packageId (InstalledOnly         p  ) = packageId p-  packageId (AvailableOnly         p  ) = packageId p-  packageId (InstalledAndAvailable p _) = packageId p---- --------------------------------------------------------------- * Tagged Dependency type--- ---------------------------------------------------------------- | Installed packages can only depend on other installed packages while--- packages that are not yet installed but which we plan to install can depend--- on installed or other not-yet-installed packages.------ This makes life more complex as we have to remember these constraints.----data TaggedDependency = TaggedDependency InstalledConstraint Dependency-data InstalledConstraint = InstalledConstraint | NoInstalledConstraint-  deriving Eq--untagDependency :: TaggedDependency -> Dependency-untagDependency (TaggedDependency _ dep) = dep
− Hackage/Dependency/Types.hs 
@@ -1,90 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Hackage.Dependency.Types--- Copyright   :  (c) Duncan Coutts 2008--- License     :  BSD-like------ Maintainer  :  cabal-devel@haskell.org--- Stability   :  provisional--- Portability :  portable------ Common types for dependency resolution.-------------------------------------------------------------------------------module Hackage.Dependency.Types (-    PackageName,-    DependencyResolver,-    PackageVersionPreference(..),-    Progress(..),-    foldProgress,-  ) where--import Hackage.Types-         ( UnresolvedDependency(..), AvailablePackage(..) )-import qualified Hackage.InstallPlan as InstallPlan--import Distribution.InstalledPackageInfo-         ( InstalledPackageInfo )-import Distribution.Simple.PackageIndex-         ( PackageIndex )-import Distribution.Compiler-         ( CompilerId )-import Distribution.System-         ( OS, Arch )--import Prelude hiding (fail)--type PackageName  = String---- | A dependency resolver is a function that works out an installation plan--- given the set of installed and available packages and a set of deps to--- solve for.------ The reason for this interface is because there are dozens of approaches to--- solving the package dependency problem and we want to make it easy to swap--- in alternatives.----type DependencyResolver a = OS-                         -> Arch-                         -> CompilerId-                         -> PackageIndex InstalledPackageInfo-                         -> PackageIndex AvailablePackage-                         -> (PackageName -> PackageVersionPreference)-                         -> [UnresolvedDependency]-                         -> Progress String String [InstallPlan.PlanPackage a]---- | A per-package preference on the version. It is a soft constraint that the--- 'DependencyResolver' should try to respect where possible.------ It is not specified if preferences on some packages are more important than--- others.----data PackageVersionPreference = 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--- retult which may be used to indicate progress and\/or logging messages.----data Progress step fail done = Step step (Progress step fail done)-                             | Fail fail-                             | Done done---- | Consume a 'Progres' calculation. Much like 'foldr' for lists but with--- two base cases, one for a final result and one for failure.------ Eg to convert into a simple 'Either' result use:------ > foldProgress (flip const) Left Right----foldProgress :: (step -> a -> a) -> (fail -> a) -> (done -> a)-             -> Progress step fail done -> a-foldProgress step fail done = fold-  where fold (Step s p) = step s (fold p)-        fold (Fail f)   = fail f-        fold (Done r)   = done r--instance Functor (Progress step fail) where-  fmap f = foldProgress Step Fail (Done . f)--instance Monad (Progress step fail) where-  return a = Done a-  p >>= f  = foldProgress Step Fail f p
− Hackage/Fetch.hs 
@@ -1,168 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Hackage.Fetch--- Copyright   :  (c) David Himmelstrup 2005--- License     :  BSD-like------ Maintainer  :  lemmih@gmail.com--- Stability   :  provisional--- Portability :  portable-------------------------------------------------------------------------------------module Hackage.Fetch-    (-     -- * Commands-     fetch-    , -- * Utilities-      fetchPackage-    , isFetched-    , downloadIndex-    ) where--import Network.URI-         ( URI(uriScheme, uriPath) )-import Network.HTTP (ConnError(..), Response(..))--import Hackage.Types-         ( UnresolvedDependency (..), AvailablePackage(..)-         , AvailablePackageSource(..), Repo(..), repoURI )-import Hackage.Dependency-         ( resolveDependencies, PackagesVersionPreference(..) )-import Hackage.IndexUtils as IndexUtils-         ( getAvailablePackages, disambiguateDependencies )-import qualified Hackage.InstallPlan as InstallPlan-import Hackage.HttpUtils (getHTTP)--import Distribution.Package-         ( PackageIdentifier(..), Package(..) )-import Distribution.Simple.Compiler-         ( Compiler(compilerId), PackageDB )-import Distribution.Simple.Program (ProgramConfiguration)-import Distribution.Simple.Configure (getInstalledPackages)-import Distribution.Simple.Utils-         ( die, notice, debug, setupMessage, intercalate )-import Distribution.System-         ( buildOS, buildArch )-import Distribution.Text-         ( display )-import Distribution.Verbosity (Verbosity)--import Control.Exception (bracket)-import Control.Monad (filterM)-import System.Directory (doesFileExist, createDirectoryIfMissing)-import System.FilePath ((</>), (<.>))-import System.Directory (copyFile)-import System.IO (IOMode(..), hPutStr, Handle, hClose, openBinaryFile)---downloadURI :: Verbosity-            -> FilePath -- ^ Where to put it-            -> URI      -- ^ What to download-            -> IO (Maybe ConnError)-downloadURI verbosity path uri-    | uriScheme uri == "file:" = do-        copyFile (uriPath uri) path-        return Nothing-    | otherwise = do-        eitherResult <- getHTTP verbosity uri-        case eitherResult of-           Left err -> return (Just err)-           Right rsp-               | rspCode rsp == (2,0,0) -> withBinaryFile path WriteMode (`hPutStr` rspBody rsp) -                                                          >> return Nothing-               | otherwise -> return (Just (ErrorMisc ("Invalid HTTP code: " ++ show (rspCode rsp))))---- Downloads a package to [config-dir/packages/package-id] and returns the path to the package.-downloadPackage :: Verbosity -> AvailablePackage -> IO String-downloadPackage verbosity pkg-    = do let uri = packageURI pkg-             dir = packageDir pkg-             path = packageFile pkg-         debug verbosity $ "GET " ++ show uri-         createDirectoryIfMissing True dir-         mbError <- downloadURI verbosity path uri-         case mbError of-           Just err -> die $ "Failed to download '" ++ display (packageId pkg) ++ "': " ++ show err-           Nothing -> return path---- Downloads an index file to [config-dir/packages/serv-id].-downloadIndex :: Verbosity -> Repo -> IO FilePath-downloadIndex verbosity repo-    = do let uri = (repoURI repo) {-                     uriPath = uriPath (repoURI repo)-                            ++ "/" ++ "00-index.tar.gz"-                   }-             dir = repoCacheDir repo-             path = dir </> "00-index" <.> "tar.gz"-         createDirectoryIfMissing True dir-         mbError <- downloadURI verbosity path uri-         case mbError of-           Just err -> die $ "Failed to download index '" ++ show err ++ "'"-           Nothing  -> return path---- |Returns @True@ if the package has already been fetched.-isFetched :: AvailablePackage -> IO Bool-isFetched pkg = doesFileExist (packageFile pkg)---- |Fetch a package if we don't have it already.-fetchPackage :: Verbosity -> AvailablePackage -> IO String-fetchPackage verbosity pkg-    = do fetched <- isFetched pkg-         if fetched-            then do notice verbosity $ "'" ++ display (packageId pkg) ++ "' is cached."-                    return (packageFile pkg)-            else do setupMessage verbosity "Downloading" (packageId pkg)-                    downloadPackage verbosity pkg---- |Fetch a list of packages and their dependencies.-fetch :: Verbosity-      -> PackageDB-      -> [Repo]-      -> Compiler-      -> ProgramConfiguration-      -> [UnresolvedDependency]-      -> IO ()-fetch verbosity packageDB repos comp conf deps-    = do installed <- getInstalledPackages verbosity comp packageDB conf-         available <- getAvailablePackages verbosity repos-         deps' <- IndexUtils.disambiguateDependencies available deps-         case resolveDependencies buildOS buildArch (compilerId comp)-                installed available PreferLatestForSelected deps' of-           Left message -> die message-           Right pkgs   -> do-             ps <- filterM (fmap not . isFetched)-                     [ pkg | (InstallPlan.Configured-                               (InstallPlan.ConfiguredPackage pkg _ _))-                                 <- InstallPlan.toList pkgs ]-             mapM_ (fetchPackage verbosity) ps--withBinaryFile :: FilePath -> IOMode -> (Handle -> IO r) -> IO r-withBinaryFile name mode = bracket (openBinaryFile name mode) hClose---- |Generate the full path to the locally cached copy of--- the tarball for a given @PackageIdentifer@.-packageFile :: AvailablePackage -> FilePath-packageFile pkg = packageDir pkg-              </> display (packageId pkg)-              <.> "tar.gz"---- |Generate the full path to the directory where the local cached copy of--- the tarball for a given @PackageIdentifer@ is stored.-packageDir :: AvailablePackage -> FilePath-packageDir AvailablePackage { packageInfoId = p-                            , packageSource = RepoTarballPackage repo } = -                         repoCacheDir repo-                     </> pkgName p-                     </> display (pkgVersion p)---- | Generate the URI of the tarball for a given package.-packageURI :: AvailablePackage -> URI-packageURI AvailablePackage { packageInfoId = p-                            , packageSource = RepoTarballPackage repo } =-  (repoURI repo) {-    uriPath = intercalate "/"-      [uriPath (repoURI repo) ,-       pkgName p, display (pkgVersion p),-       display p ++ ".tar.gz"]-  }
− Hackage/HttpUtils.hs 
@@ -1,134 +0,0 @@-{-# OPTIONS -cpp #-}--------------------------------------------------------------------------------- | Separate module for HTTP actions, using a proxy server if one exists -------------------------------------------------------------------------------module Hackage.HttpUtils (getHTTP, proxy) where--import Network.HTTP-         ( Request (..), Response (..), RequestMethod (..)-         , Header(..), HeaderName(..) )-import Network.URI-         ( URI (..), URIAuth (..), parseAbsoluteURI )-import Network.Stream (Result)-import Network.Browser (Proxy (..), Authority (..), browse,-                        setOutHandler, setErrHandler, setProxy, request)-import Control.Monad-         ( mplus, join )-#ifdef WIN32-import System.Win32.Types-         ( DWORD, HKEY )-import System.Win32.Registry-         ( hKEY_CURRENT_USER, regOpenKey, regCloseKey-         , regQueryValue, regQueryValueEx )-import Control.Exception-         ( handle, bracket )-import Foreign-         ( toBool, Storable(peek, sizeOf), castPtr, alloca )-#else-import System.Environment (getEnvironment)-#endif--import qualified Paths_cabal_install (version)-import Distribution.Verbosity (Verbosity)-import Distribution.Simple.Utils (warn, debug)-import Distribution.Text-         ( display )---- FIXME: all this proxy stuff is far too complicated, especially parsing--- the proxy strings. Network.Browser should have a way to pick up the--- proxy settings hiding all this system-dependent stuff below.---- try to read the system proxy settings on windows or unix-proxyString :: IO (Maybe String)-#ifdef WIN32--- read proxy settings from the windows registry-proxyString = handle (\_ -> return Nothing) $-  bracket (regOpenKey hive path) regCloseKey $ \hkey -> do-    enable <- fmap toBool $ regQueryValueDWORD hkey "ProxyEnable"-    if enable-        then fmap Just $ regQueryValue hkey (Just "ProxyServer")-        else return Nothing-  where-    -- some sources say proxy settings should be at -    -- HKEY_LOCAL_MACHINE\SOFTWARE\Policies\Microsoft\Windows-    --                   \CurrentVersion\Internet Settings\ProxyServer-    -- but if the user sets them with IE connection panel they seem to-    -- end up in the following place:-    hive  = hKEY_CURRENT_USER-    path = "Software\\Microsoft\\Windows\\CurrentVersion\\Internet Settings"--    regQueryValueDWORD :: HKEY -> String -> IO DWORD-    regQueryValueDWORD hkey name = alloca $ \ptr -> do-      regQueryValueEx hkey name (castPtr ptr) (sizeOf (undefined :: DWORD))-      peek ptr-#else--- read proxy settings by looking for an env var-proxyString = do-  env <- getEnvironment-  return (lookup "http_proxy" env `mplus` lookup "HTTP_PROXY" env)-#endif---- |Get the local proxy settings  -proxy :: Verbosity -> IO Proxy-proxy verbosity = do-  mstr <- proxyString-  case mstr of-    Nothing   -> return NoProxy-    Just str  -> case parseHttpProxy str of-      Nothing -> do-        warn verbosity $ "invalid http proxy uri: " ++ show str-        warn verbosity $ "proxy uri must be http with a hostname"-        warn verbosity $ "ignoring http proxy, trying a direct connection"-        return NoProxy-      Just p  -> return p---- | We need to be able to parse non-URIs like @\"wwwcache.example.com:80\"@--- which lack the @\"http://\"@ URI scheme. The problem is that--- @\"wwwcache.example.com:80\"@ is in fact a valid URI but with scheme--- @\"wwwcache.example.com:\"@, no authority part and a path of @\"80\"@.------ So our strategy is to try parsing as normal uri first and if it lacks the--- 'uriAuthority' then we try parsing again with a @\"http://\"@ prefix.----parseHttpProxy :: String -> Maybe Proxy-parseHttpProxy str = join-                   . fmap uri2proxy-                   $ parseHttpURI str-             `mplus` parseHttpURI ("http://" ++ str)-  where-    parseHttpURI str' = case parseAbsoluteURI str' of-      Just uri@URI { uriAuthority = Just _ }-         -> Just uri-      _  -> Nothing--uri2proxy :: URI -> Maybe Proxy-uri2proxy uri@URI{ uriScheme = "http:"-                 , uriAuthority = Just (URIAuth auth' host port)-                 } = Just (Proxy (host ++ port) auth)-  where auth = if null auth'-                 then Nothing-                 else Just (AuthBasic "" usr pwd uri)-        (usr,pwd') = break (==':') auth'-        pwd        = case pwd' of-                       ':':cs -> cs-                       _      -> pwd'-uri2proxy _ = Nothing--mkRequest :: URI -> Request-mkRequest uri = Request{ rqURI     = uri-                       , rqMethod  = GET-                       , rqHeaders = [Header HdrUserAgent userAgent]-                       , rqBody    = "" }-  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 = do-                 p   <- proxy verbosity-                 let req = mkRequest uri-                 (_, resp) <- browse $ do-                                setErrHandler (warn verbosity . ("http error: "++))-                                setOutHandler (debug verbosity)-                                setProxy p-                                request req-                 return (Right resp)
− Hackage/IndexUtils.hs 
@@ -1,129 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Hackage.IndexUtils--- Copyright   :  (c) Duncan Coutts 2008--- License     :  BSD-like------ Maintainer  :  duncan@haskell.org--- Stability   :  provisional--- Portability :  portable------ Extra utils related to the package indexes.-------------------------------------------------------------------------------module Hackage.IndexUtils (-  getAvailablePackages,-  readRepoIndex,-  disambiguatePackageName,-  disambiguateDependencies-  ) where--import Hackage.Tar-import Hackage.Types-         ( UnresolvedDependency(..), AvailablePackage(..)-         , AvailablePackageSource(..), Repo(..) )--import Distribution.Package (PackageIdentifier(..), Package(..), Dependency(Dependency))-import Distribution.Simple.PackageIndex (PackageIndex)-import qualified Distribution.Simple.PackageIndex as PackageIndex-import Distribution.PackageDescription-         ( parsePackageDescription )-import Distribution.ParseUtils-         ( ParseResult(..) )-import Distribution.Text-         ( simpleParse )-import Distribution.Verbosity (Verbosity)-import Distribution.Simple.Utils (die, warn, info, intercalate, fromUTF8)--import Prelude hiding (catch)-import Data.Monoid (Monoid(mconcat))-import Control.Exception (evaluate, catch, Exception(IOException))-import qualified Data.ByteString.Lazy as BS-import qualified Data.ByteString.Lazy.Char8 as BS.Char8-import Data.ByteString.Lazy (ByteString)-import System.FilePath ((</>), takeExtension, splitDirectories, normalise)-import System.IO.Error (isDoesNotExistError)---getAvailablePackages :: Verbosity -> [Repo]-                     -> IO (PackageIndex AvailablePackage)-getAvailablePackages verbosity repos = do-  info verbosity "Reading available packages..."-  pkgss <- mapM (readRepoIndex verbosity) repos-  evaluate (mconcat pkgss)---- | Read a repository index from disk, from the local file specified by--- the 'Repo'.----readRepoIndex :: Verbosity -> Repo -> IO (PackageIndex AvailablePackage)-readRepoIndex verbosity repo =-  let indexFile = repoCacheDir repo </> "00-index.tar"-   in fmap parseRepoIndex (BS.readFile indexFile)-          `catch` (\e -> do case e of-                              IOException ioe | isDoesNotExistError ioe ->-                                warn verbosity "The package list does not exist. Run 'cabal update' to download it."-                              _ -> warn verbosity (show e)-                            return (PackageIndex.fromList []))--  where-    -- | Parse a repository index file from a 'ByteString'.-    ---    -- All the 'AvailablePackage's are marked as having come from the given 'Repo'.-    ---    parseRepoIndex :: ByteString -> PackageIndex AvailablePackage-    parseRepoIndex s = PackageIndex.fromList $ do-      (hdr, content) <- readTarArchive s-      if takeExtension (tarFileName hdr) == ".cabal"-        then case splitDirectories (normalise (tarFileName hdr)) of-               [pkgname,vers,_] ->-                 let parsed = parsePackageDescription-                                (fromUTF8 . BS.Char8.unpack $ content)-                     descr  = case parsed of-                       ParseOk _ d -> d-                       _           -> error $ "Couldn't read cabal file "-                                           ++ show (tarFileName hdr)-                  in case simpleParse vers of-                       Just ver -> return AvailablePackage {-                           packageInfoId = PackageIdentifier pkgname ver,-                           packageDescription = descr,-                           packageSource = RepoTarballPackage repo-                         }-                       _ -> []-               _ -> []-        else []---- | Disambiguate a set of packages using 'disambiguatePackage' and report any--- ambiguities to the user.----disambiguateDependencies :: PackageIndex AvailablePackage-                         -> [UnresolvedDependency]-                         -> IO [UnresolvedDependency]-disambiguateDependencies index deps = do-  let names = [ (name, disambiguatePackageName index name)-              | UnresolvedDependency (Dependency name _) _ <- deps ]-   in case [ (name, matches) | (name, Right matches) <- names ] of-        []        -> return-          [ UnresolvedDependency (Dependency name vrange) flags-          | (UnresolvedDependency (Dependency _ vrange) flags,-             (_, Left name)) <- zip deps names ]-        ambigious -> die $ unlines-          [ if null matches-              then "There is no package named " ++ name-              else "The package name " ++ name ++ "is ambigious. "-                ++ "It could be: " ++ intercalate ", " matches-          | (name, matches) <- ambigious ]---- | Given an index of known packages and a package name, figure out which one it--- might be referring to. If there is an exact case-sensitive match then that's--- ok. If it matches just one package case-insensitively then that's also ok.--- The only problem is if it matches multiple packages case-insensitively, in--- that case it is ambigious.----disambiguatePackageName :: PackageIndex AvailablePackage-                        -> String-                        -> Either String [String]-disambiguatePackageName index name =-    case PackageIndex.searchByName index name of-      PackageIndex.None              -> Right []-      PackageIndex.Unambiguous pkgs  -> Left (pkgName (packageId (head pkgs)))-      PackageIndex.Ambiguous   pkgss -> Right [ pkgName (packageId pkg)-                                           | (pkg:_) <- pkgss ]
− Hackage/Install.hs 
@@ -1,346 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Hackage.Install--- Copyright   :  (c) David Himmelstrup 2005--- License     :  BSD-like------ Maintainer  :  lemmih@gmail.com--- Stability   :  provisional--- Portability :  portable------ High level interface to package installation.-------------------------------------------------------------------------------module Hackage.Install (-    install,-    upgrade,-  ) where--import Data.List-         ( unfoldr )-import Control.Exception as Exception-         ( handle, Exception )-import Control.Monad-         ( when, unless )-import System.Directory-         ( getTemporaryDirectory, doesFileExist )-import System.FilePath ((</>),(<.>))--import Hackage.Dependency-         ( resolveDependenciesWithProgress, PackagesVersionPreference(..)-         , upgradableDependencies )-import Hackage.Dependency.Types (Progress(..), foldProgress)-import Hackage.Fetch (fetchPackage)--- import qualified Hackage.Info as Info-import Hackage.IndexUtils as IndexUtils-         ( getAvailablePackages, disambiguateDependencies )-import qualified Hackage.InstallPlan as InstallPlan-import Hackage.InstallPlan (InstallPlan)-import Hackage.Setup-         ( InstallFlags(..), configureCommand, filterConfigureFlags )-import Hackage.Tar (extractTarGzFile)-import Hackage.Types as Available-         ( UnresolvedDependency(..), AvailablePackage(..)-         , AvailablePackageSource(..), Repo, ConfiguredPackage(..)-         , BuildResult(..) )-import Hackage.SetupWrapper-         ( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions )-import Hackage.Reporting-         ( writeInstallPlanBuildReports )-import Paths_cabal_install (getBinDir)--import Distribution.Simple.Compiler-         ( Compiler(compilerId), PackageDB(..) )-import Distribution.Simple.Program (ProgramConfiguration, defaultProgramConfiguration)-import Distribution.Simple.Configure (getInstalledPackages)-import qualified Distribution.Simple.Setup as Cabal-import qualified Distribution.Simple.PackageIndex as PackageIndex-import Distribution.Simple.PackageIndex (PackageIndex)-import Distribution.Simple.Setup-         ( flagToMaybe )-import Distribution.Simple.Utils-         ( defaultPackageDesc, inDir, rawSystemExit, withTempDirectory )-import Distribution.Package-         ( PackageIdentifier(..), Package(..), thisPackageVersion )-import Distribution.PackageDescription as PackageDescription-         ( GenericPackageDescription(packageDescription)-         , readPackageDescription )-import Distribution.InstalledPackageInfo-         ( InstalledPackageInfo )-import Distribution.Version-         ( Version, VersionRange(AnyVersion, ThisVersion) )-import Distribution.Simple.Utils as Utils (notice, info, die)-import Distribution.System-         ( buildOS, buildArch )-import Distribution.Text-         ( display )-import Distribution.Verbosity (Verbosity, showForCabal, verbose)-import Distribution.Simple.BuildPaths ( exeExtension )--data InstallMisc = InstallMisc {-    rootCmd    :: Maybe FilePath,-    libVersion :: Maybe Version-  }---- |Installs the packages needed to satisfy a list of dependencies.-install, upgrade-  :: Verbosity-  -> PackageDB-  -> [Repo]-  -> Compiler-  -> ProgramConfiguration-  -> Cabal.ConfigFlags-  -> InstallFlags-  -> [UnresolvedDependency]-  -> IO ()-install verbosity packageDB repos comp conf configFlags installFlags deps =-  installWithPlanner planner-        verbosity packageDB repos comp conf configFlags installFlags-  where-    planner :: Planner-    planner | null deps = planLocalPackage verbosity comp configFlags-            | otherwise = planRepoPackages PreferLatestForSelected comp deps--upgrade verbosity packageDB repos comp conf configFlags installFlags deps =-  installWithPlanner planner-        verbosity packageDB repos comp conf configFlags installFlags-  where-    planner :: Planner-    planner | null deps = planUpgradePackages comp-            | otherwise = planRepoPackages PreferAllLatest comp deps--type Planner = Maybe (PackageIndex InstalledPackageInfo)-            -> PackageIndex AvailablePackage-            -> IO (Progress String String (InstallPlan BuildResult))---- |Installs the packages generated by a planner.-installWithPlanner ::-           Planner-        -> Verbosity-        -> PackageDB-        -> [Repo]-        -> Compiler-        -> ProgramConfiguration-        -> Cabal.ConfigFlags-        -> InstallFlags-        -> IO ()-installWithPlanner planner verbosity packageDB repos comp conf configFlags installFlags = do-  installed <- getInstalledPackages verbosity comp packageDB conf-  available <- getAvailablePackages verbosity repos--  progress <- planner installed available--  notice verbosity "Resolving dependencies..."-  maybePlan <- foldProgress (\message rest -> info verbosity message >> rest)-                            (return . Left) (return . Right) progress-  case maybePlan of-    Left message -> die message-    Right installPlan -> do-      when (dryRun || verbosity >= verbose) $-        printDryRun verbosity installPlan--      unless dryRun $ do-        installPlan' <--          executeInstallPlan installPlan $ \cpkg ->-            installConfiguredPackage configFlags cpkg $ \configFlags' apkg ->-              installAvailablePackage verbosity apkg $-                installUnpackedPackage verbosity (setupScriptOptions installed)-                                       miscOptions configFlags'-        writeInstallPlanBuildReports installPlan'-        printBuildFailures installPlan'--  where-    setupScriptOptions index = SetupScriptOptions {-      useCabalVersion  = maybe AnyVersion ThisVersion (libVersion miscOptions),-      useCompiler      = Just comp,-      usePackageIndex  = if packageDB == UserPackageDB then index else Nothing,-      useProgramConfig = conf,-      useDistPref      = Cabal.fromFlagOrDefault-                           (useDistPref defaultSetupScriptOptions)-                           (Cabal.configDistPref configFlags)-    }-    dryRun       = Cabal.fromFlag (installDryRun installFlags)-    miscOptions  = InstallMisc {-      rootCmd    = if Cabal.fromFlag (Cabal.configUserInstall configFlags)-                     then Nothing      -- ignore --root-cmd if --user.-                     else Cabal.flagToMaybe (installRootCmd installFlags),-      libVersion = Cabal.flagToMaybe (installCabalVersion installFlags)-    }---- | 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 available = do-  pkg <- readPackageDescription verbosity =<< defaultPackageDesc verbosity-  let -- The trick is, we add the local package to the available index and-      -- remove it from the installed index. Then we ask to resolve a-      -- dependency on exactly that package. So the resolver ends up having-      -- to pick the local package.-      available' = PackageIndex.insert localPkg available-      installed' = PackageIndex.deletePackageId (packageId localPkg) `fmap` installed-      localPkg = AvailablePackage {-        packageInfoId                = packageId pkg,-        Available.packageDescription = pkg,-        packageSource                = LocalUnpackedPackage-      }-      localPkgDep = UnresolvedDependency {-        dependency = thisPackageVersion (packageId localPkg),-        depFlags   = Cabal.configConfigurationsFlags configFlags-      }--  return $ resolveDependenciesWithProgress buildOS buildArch (compilerId comp)-             installed' available' PreferLatestForSelected [localPkgDep]---- | Make an 'InstallPlan' for the given dependencies.----planRepoPackages :: PackagesVersionPreference -> Compiler-                 -> [UnresolvedDependency] -> Planner-planRepoPackages pref comp deps installed available = do-  deps' <- IndexUtils.disambiguateDependencies available deps-  return $ resolveDependenciesWithProgress buildOS buildArch (compilerId comp)-             installed available pref deps'--planUpgradePackages :: Compiler -> Planner-planUpgradePackages comp (Just installed) available = return $-  resolveDependenciesWithProgress buildOS buildArch (compilerId comp)-    (Just installed) available PreferAllLatest-    [ UnresolvedDependency dep []-    | dep <- upgradableDependencies installed available ]-planUpgradePackages comp _ _ =-  die $ display (compilerId comp)-     ++ " does not track installed packages so cabal cannot figure out what"-     ++ " packages need to be upgraded."--printDryRun :: Verbosity -> InstallPlan BuildResult -> IO ()-printDryRun verbosity plan = case unfoldr next plan of-  []   -> notice verbosity "No packages to be installed."-  pkgs -> notice verbosity $ unlines $-            "In order, the following would be installed:"-          : map display pkgs-  where-    next plan' = case InstallPlan.ready plan' of-      []      -> Nothing-      (pkg:_) -> Just (pkgid, InstallPlan.completed pkgid plan')-        where pkgid = packageId pkg--printBuildFailures :: InstallPlan BuildResult -> IO ()-printBuildFailures plan =-  case [ (pkg, reason)-       | InstallPlan.Failed pkg reason <- InstallPlan.toList plan ] of-    []     -> return ()-    failed -> die . unlines-            $ "Error: some packages failed to install:"-            : [ display (packageId pkg) ++ printFailureReason reason-              | (pkg, reason) <- failed ]-  where-    printFailureReason reason = case reason of-      DependentFailed pkgid -> " depends on " ++ display pkgid-                            ++ " which failed to install."-      UnpackFailed    e -> " failed while unpacking the package."-                        ++ " The exception was:\n  " ++ show e-      ConfigureFailed e -> " failed during the configure step."-                        ++ " The exception was:\n  " ++ show e-      BuildFailed     e -> " failed during the building phase."-                        ++ " The exception was:\n  " ++ show e-      InstallFailed   e -> " failed during the final install step."-                        ++ " The exception was:\n  " ++ show e-      _ -> ""--executeInstallPlan :: Monad m-                   => InstallPlan BuildResult-                   -> (ConfiguredPackage -> m BuildResult)-                   -> m (InstallPlan BuildResult)-executeInstallPlan plan installPkg = case InstallPlan.ready plan of-  [] -> return plan-  (pkg: _) -> do-    buildResult <- installPkg pkg-    let pkgid = packageId pkg-        updatePlan = case buildResult of-          BuildOk -> InstallPlan.completed pkgid-          _       -> InstallPlan.failed    pkgid buildResult depsResult-            where depsResult = DependentFailed pkgid-            -- So this first pkgid failed for whatever reason (buildResult)-            -- all the other packages that depended on this pkgid which we-            -- now cannot build we mark as failing due to DependentFailed-            -- which kind of means it was not their fault.-    executeInstallPlan (updatePlan plan) installPkg---- | 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.----installConfiguredPackage ::  Cabal.ConfigFlags -> ConfiguredPackage-                         -> (Cabal.ConfigFlags -> AvailablePackage  -> a)-                         -> a-installConfiguredPackage configFlags (ConfiguredPackage pkg flags deps)-  installPkg = installPkg configFlags {-    Cabal.configConfigurationsFlags = flags,-    Cabal.configConstraints = map thisPackageVersion deps-  } pkg--installAvailablePackage-  :: Verbosity -> AvailablePackage-  -> (GenericPackageDescription -> Maybe FilePath -> IO BuildResult)-  -> IO BuildResult-installAvailablePackage _ (AvailablePackage _ pkg LocalUnpackedPackage)-  installPkg = installPkg pkg Nothing--installAvailablePackage verbosity apkg@(AvailablePackage _ pkg _)-  installPkg = do-  pkgPath <- fetchPackage verbosity apkg-  tmp <- getTemporaryDirectory-  let pkgid = packageId pkg-      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-                                  </> pkgName pkgid <.> "cabal"-    exists <- doesFileExist descFilePath-    when (not exists) $-      die $ "Package .cabal file not found: " ++ show descFilePath-    installPkg pkg (Just path)--installUnpackedPackage :: Verbosity-                   -> SetupScriptOptions-                   -> InstallMisc-                   -> Cabal.ConfigFlags-                   -> GenericPackageDescription-                   -> Maybe FilePath -- ^ Directory to change to before starting the installation.-                   -> IO BuildResult-installUnpackedPackage verbosity scriptOptions miscOptions configFlags pkg mpath-    = onFailure ConfigureFailed $ do-        setup configureCommand (filterConfigureFlags configFlags)-        onFailure BuildFailed $ do-          setup buildCommand (const Cabal.emptyBuildFlags)-          onFailure InstallFailed $ do-            case rootCmd miscOptions of-              (Just cmd) -> reexec cmd-              Nothing    -> setup Cabal.installCommand-                                  (const Cabal.emptyInstallFlags)-            return BuildOk-  where-    buildCommand     = Cabal.buildCommand defaultProgramConfiguration-    setup cmd flags  = inDir mpath $-                         setupWrapper verbosity scriptOptions-                           (Just $ PackageDescription.packageDescription pkg)-                           cmd flags []-    reexec cmd = do-      -- look for our on executable file and re-exec ourselves using-      -- a helper program like sudo to elevate priviledges:-      bindir <- getBinDir-      let self = bindir </> "cabal" <.> exeExtension-      weExist <- doesFileExist self-      if weExist-        then inDir mpath $-               rawSystemExit verbosity cmd-                 [self, "install", "--only"-                 ,"--verbose=" ++ showForCabal verbosity]-        else die $ "Unable to find cabal executable at: " ++ self-               --- helper-onFailure :: (Exception -> BuildResult) -> IO BuildResult -> IO BuildResult-onFailure result = Exception.handle (return . result)
− Hackage/InstallPlan.hs 
@@ -1,497 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Hackage.InstallPlan--- Copyright   :  (c) Duncan Coutts 2008--- License     :  BSD-like------ Maintainer  :  duncan@haskell.org--- Stability   :  provisional--- Portability :  portable------ Package installation plan----------------------------------------------------------------------------------module Hackage.InstallPlan (-  InstallPlan,-  ConfiguredPackage(..),-  PlanPackage(..),--  -- * Operations on 'InstallPlan's-  new,-  toList,-  ready,-  completed,-  failed,--  -- ** Query functions-  planOS,-  planArch,-  planCompiler,--  -- * Checking valididy of plans-  valid,-  closed,-  consistent,-  acyclic,-  configuredPackageValid,--  -- ** Details on invalid plans-  PlanProblem(..),-  showPlanProblem,-  PackageProblem(..),-  showPackageProblem,-  problems,-  configuredPackageProblems-  ) where--import Hackage.Types-         ( AvailablePackage(packageDescription), ConfiguredPackage(..) )-import Distribution.Package-         ( PackageIdentifier(..), Package(..), PackageFixedDeps(..)-         , packageName, Dependency(..) )-import Distribution.Version-         ( Version, withinRange )-import Distribution.InstalledPackageInfo-         ( InstalledPackageInfo )-import Distribution.PackageDescription-         ( GenericPackageDescription(genPackageFlags)-         , PackageDescription(buildDepends)-         , Flag(flagName), FlagName(..) )-import Distribution.PackageDescription.Configuration-         ( finalizePackageDescription )-import Distribution.Simple.PackageIndex-         ( PackageIndex )-import qualified Distribution.Simple.PackageIndex as PackageIndex-import Distribution.Text-         ( display )-import Distribution.System-         ( OS, Arch )-import Distribution.Compiler-         ( CompilerId(..) )-import Hackage.Utils-         ( duplicates, duplicatesBy, mergeBy, MergeResult(..) )-import Distribution.Simple.Utils-         ( comparing, intercalate )--import Data.List-         ( sort, sortBy )-import Data.Maybe-         ( fromMaybe )-import qualified Data.Graph as Graph-import Data.Graph (Graph)-import Control.Exception-         ( assert )---- When cabal tries to install a number of packages, including all their--- dependencies it has a non-trivial problem to solve.------ The Problem:------ In general we start with a set of installed packages and a set of available--- packages.------ Installed packages have fixed dependencies. They have already been built and--- we know exactly what packages they were built against, including their exact--- versions. ------ Available package have somewhat flexible dependencies. They are specified as--- version ranges, though really they're predicates. To make matters worse they--- have conditional flexible dependencies. Configuration flags can affect which--- packages are required and can place additional constraints on their--- versions.------ These two sets of package can and usually do overlap. There can be installed--- packages that are also available which means they could be re-installed if--- required, though there will also be packages which are not available and--- cannot be re-installed. Very often there will be extra versions available--- than are installed. Sometimes we may like to prefer installed packages over--- available ones or perhaps always prefer the latest available version whether--- installed or not.------ The goal is to calculate an installation plan that is closed, acyclic and--- consistent and where every configured package is valid.------ An installation plan is a set of packages that are going to be used--- together. It will consist of a mixture of installed packages and available--- packages along with their exact version dependencies. An installation plan--- is closed if for every package in the set, all of its dependencies are--- also in the set. It is consistent if for every package in the set, all--- dependencies which target that package have the same version.---- Note that plans do not necessarily compose. You might have a valid plan for--- package A and a valid plan for package B. That does not mean the composition--- is simultaniously valid for A and B. In particular you're most likely to--- have problems with inconsistent dependencies.--- On the other hand it is true that every closed sub plan is valid.--data PlanPackage buildResult = PreExisting InstalledPackageInfo-                             | Configured  ConfiguredPackage-                             | Installed   ConfiguredPackage-                             | Failed      ConfiguredPackage buildResult-  deriving Show--instance Package (PlanPackage buildResult) where-  packageId (PreExisting pkg) = packageId pkg-  packageId (Configured pkg)  = packageId pkg-  packageId (Installed pkg)   = packageId pkg-  packageId (Failed pkg _)    = packageId pkg--instance PackageFixedDeps (PlanPackage buildResult) where-  depends (PreExisting pkg) = depends pkg-  depends (Configured pkg)  = depends pkg-  depends (Installed pkg)   = depends pkg-  depends (Failed pkg _)    = depends pkg--data InstallPlan buildResult = InstallPlan {-    planIndex    :: PackageIndex (PlanPackage buildResult),-    planGraph    :: Graph,-    planGraphRev :: Graph,-    planPkgIdOf  :: Graph.Vertex -> PackageIdentifier,-    planVertexOf :: PackageIdentifier -> Graph.Vertex,-    planOS       :: OS,-    planArch     :: Arch,-    planCompiler :: CompilerId-  }--invariant :: InstallPlan a -> Bool-invariant plan =-  valid (planOS plan) (planArch 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 a)-    -> Either [PlanProblem a] (InstallPlan a)-new os arch compiler index =-  case problems os arch compiler index of-    [] -> Right InstallPlan {-            planIndex    = index,-            planGraph    = graph,-            planGraphRev = Graph.transposeG graph,-            planPkgIdOf  = vertexToPkgId,-            planVertexOf = fromMaybe noSuchPkgId . pkgIdToVertex,-            planOS       = os,-            planArch     = arch,-            planCompiler = compiler-          }-      where (graph, vertexToPkgId, pkgIdToVertex) =-              PackageIndex.dependencyGraph index-            noSuchPkgId = internalError "package is not in the graph"-    probs -> Left probs--toList :: InstallPlan buildResult -> [PlanPackage buildResult]-toList = PackageIndex.allPackages . planIndex---- | The packages that are ready to be installed. That is they are in the--- configured state and have all their dependencies installed already.--- The plan is complete if the result is @[]@.----ready :: InstallPlan buildResult -> [ConfiguredPackage]-ready plan = assert check readyPackages-  where-    check = if null readyPackages then null configuredPackages else True-    configuredPackages =-      [ pkg | Configured pkg <- PackageIndex.allPackages (planIndex plan) ]-    readyPackages = filter (all isInstalled . depends) configuredPackages-    isInstalled pkg =-      case PackageIndex.lookupPackageId (planIndex plan) pkg of-        Just (Configured  _) -> False-        Just (Failed    _ _) -> internalError depOnFailed-        Just (PreExisting _) -> True-        Just (Installed   _) -> True-        Nothing              -> internalError incomplete-    incomplete  = "install plan is not closed"-    depOnFailed = "configured package depends on failed package"---- | Marks a package in the graph as completed. Also saves the build result for--- the completed package in the plan.------ * The package must exist in the graph.--- * The package must have had no uninstalled dependent packages.----completed :: PackageIdentifier-          -> InstallPlan buildResult -> InstallPlan buildResult-completed pkgid plan = assert (invariant plan') plan'-  where-    plan'     = plan {-                  planIndex = PackageIndex.insert installed (planIndex plan)-                }-    installed = Installed (lookupConfiguredPackage plan pkgid)---- | Marks a package in the graph as having failed. It also marks all the--- packages that depended on it as having failed.------ * The package must exist in the graph and be in the configured state.----failed :: PackageIdentifier -- ^ The id of the package that failed to install-       -> buildResult       -- ^ The build result to use for the failed package-       -> buildResult       -- ^ The build result to use for its dependencies-       -> InstallPlan buildResult-       -> InstallPlan buildResult-failed pkgid buildResult buildResult' plan = assert (invariant plan') plan'-  where-    plan'    = plan {-                 planIndex = PackageIndex.merge (planIndex plan) failures-               }-    pkg      = lookupConfiguredPackage plan pkgid-    failures = PackageIndex.fromList-             $ Failed pkg buildResult-             : [ Failed pkg' buildResult'-               | Just pkg' <- map (lookupConfiguredPackage' plan)-                            $ packagesThatDependOn plan pkgid ]---- | lookup the reachable packages in the reverse dependency graph----packagesThatDependOn :: InstallPlan a-                     -> PackageIdentifier -> [PackageIdentifier]-packagesThatDependOn plan = map (planPkgIdOf plan)-                          . tail-                          . Graph.reachable (planGraphRev plan)-                          . planVertexOf plan---- | lookup a package that we expect to be in the configured state----lookupConfiguredPackage :: InstallPlan a-                        -> PackageIdentifier -> ConfiguredPackage-lookupConfiguredPackage plan pkgid =-  case PackageIndex.lookupPackageId (planIndex plan) pkgid of-    Just (Configured pkg) -> pkg-    _  -> internalError $ "not configured or no such pkg " ++ display pkgid---- | lookup a package that we expect to be in the configured or failed state----lookupConfiguredPackage' :: InstallPlan a-                         -> PackageIdentifier -> Maybe ConfiguredPackage-lookupConfiguredPackage' plan pkgid =-  case PackageIndex.lookupPackageId (planIndex plan) pkgid of-    Just (Configured pkg) -> Just pkg-    Just (Failed _ _)     -> Nothing-    _  -> internalError $ "not configured or no such pkg " ++ display pkgid---- --------------------------------------------------------------- * Checking valididy of plans--- ---------------------------------------------------------------- | A valid installation plan is a set of packages that is 'acyclic',--- 'closed' and 'consistent'. Also, every 'ConfiguredPackage' in the--- plan has to have a valid configuration (see 'configuredPackageValid').------ * if the result is @False@ use 'problems' to get a detailed list.----valid :: OS -> Arch -> CompilerId -> PackageIndex (PlanPackage a) -> Bool-valid os arch comp index = null (problems os arch comp index)--data PlanProblem a =-     PackageInvalid       ConfiguredPackage [PackageProblem]-   | PackageMissingDeps   (PlanPackage a) [PackageIdentifier]-   | PackageCycle         [PlanPackage a]-   | PackageInconsistency String [(PackageIdentifier, Version)]-   | PackageStateInvalid  (PlanPackage a) (PlanPackage a)--showPlanProblem :: PlanProblem a -> String-showPlanProblem (PackageInvalid pkg packageProblems) =-     "Package " ++ display (packageId pkg)-  ++ " has an invalid configuration, in particular:\n"-  ++ unlines [ "  " ++ showPackageProblem problem-             | problem <- packageProblems ]--showPlanProblem (PackageMissingDeps pkg missingDeps) =-     "Package " ++ display (packageId pkg)-  ++ " depends on the following packages which are missing from the plan "-  ++ intercalate ", " (map display missingDeps)--showPlanProblem (PackageCycle cycleGroup) =-     "The following packages are involved in a dependency cycle "-  ++ intercalate ", " (map (display.packageId) cycleGroup)--showPlanProblem (PackageInconsistency name inconsistencies) =-     "Package " ++ name-  ++ " is required by several packages,"-  ++ " but they require inconsistent versions:\n"-  ++ unlines [ "  package " ++ display pkg ++ " requires "-                            ++ display (PackageIdentifier name ver)-             | (pkg, ver) <- inconsistencies ]--showPlanProblem (PackageStateInvalid pkg pkg') =-     "Package " ++ display (packageId pkg)-  ++ " is in the " ++ showPlanState pkg-  ++ " state but it depends on package " ++ display (packageId pkg')-  ++ " which is in the " ++ showPlanState pkg'-  ++ " state"-  where-    showPlanState (PreExisting _) = "pre-existing"-    showPlanState (Configured  _) = "configured"-    showPlanState (Installed   _) = "installed"-    showPlanState (Failed    _ _) = "failed"---- | For an invalid plan, produce a detailed list of problems as human readable--- error messages. This is mainly intended for debugging purposes.--- Use 'showPlanProblem' for a human readable explanation.----problems :: OS -> Arch -> CompilerId-         -> PackageIndex (PlanPackage a) -> [PlanProblem a]-problems os arch comp index =-     [ PackageInvalid pkg packageProblems-     | Configured pkg <- PackageIndex.allPackages index-     , let packageProblems = configuredPackageProblems os arch comp pkg-     , not (null packageProblems) ]--  ++ [ PackageMissingDeps pkg missingDeps-     | (pkg, missingDeps) <- PackageIndex.brokenPackages index ]--  ++ [ PackageCycle cycleGroup-     | cycleGroup <- PackageIndex.dependencyCycles index ]--  ++ [ PackageInconsistency name inconsistencies-     | (name, inconsistencies) <- PackageIndex.dependencyInconsistencies index ]--  ++ [ PackageStateInvalid pkg pkg'-     | pkg <- PackageIndex.allPackages index-     , Just pkg' <- map (PackageIndex.lookupPackageId index) (depends pkg)-     , not (stateDependencyRelation pkg pkg') ]---- | The graph of packages (nodes) and dependencies (edges) must be acyclic.------ * if the result is @False@ use 'PackageIndex.dependencyCycles' to find out---   which packages are involved in dependency cycles.----acyclic :: PackageIndex (PlanPackage a) -> Bool-acyclic = null . PackageIndex.dependencyCycles---- | An installation plan is closed if for every package in the set, all of--- its dependencies are also in the set. That is, the set is closed under the--- dependency relation.------ * if the result is @False@ use 'PackageIndex.brokenPackages' to find out---   which packages depend on packages not in the index.----closed :: PackageIndex (PlanPackage a) -> Bool-closed = null . PackageIndex.brokenPackages---- | An installation plan is consistent if all dependencies that target a--- single package name, target the same version.------ This is slightly subtle. It is not the same as requiring that there be at--- most one version of any package in the set. It only requires that of--- packages which have more than one other package depending on them. We could--- actually make the condition even more precise and say that different--- versions are ok so long as they are not both in the transative closure of--- any other package (or equivalently that their inverse closures do not--- intersect). The point is we do not want to have any packages depending--- directly or indirectly on two different versions of the same package. The--- current definition is just a safe aproximation of that.------ * if the result is @False@ use 'PackageIndex.dependencyInconsistencies' to---   find out which packages are.----consistent :: PackageIndex (PlanPackage a) -> Bool-consistent = null . PackageIndex.dependencyInconsistencies---- | The states of packages have that depend on each other must respect--- this relation. That is for very case where package @a@ depends on--- package @b@ we require that @dependencyStatesOk a b = True@.----stateDependencyRelation :: PlanPackage a -> PlanPackage a -> Bool-stateDependencyRelation (PreExisting _) (PreExisting _) = True--stateDependencyRelation (Configured  _) (PreExisting _) = True-stateDependencyRelation (Configured  _) (Configured  _) = True-stateDependencyRelation (Configured  _) (Installed   _) = True--stateDependencyRelation (Installed   _) (PreExisting _) = True-stateDependencyRelation (Installed   _) (Installed   _) = True--stateDependencyRelation (Failed    _ _) (PreExisting _) = True--- failed can depends on configured because a package can depend on--- several other packages and if one of the deps fail then we fail--- but we still depend on the other ones that did not fail:-stateDependencyRelation (Failed    _ _) (Configured  _) = True-stateDependencyRelation (Failed    _ _) (Installed   _) = True-stateDependencyRelation (Failed    _ _) (Failed    _ _) = True--stateDependencyRelation _               _               = False---- | A 'ConfiguredPackage' is valid if the flag assignment is total and if--- 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)--data PackageProblem = DuplicateFlag FlagName-                    | MissingFlag   FlagName-                    | ExtraFlag     FlagName-                    | DuplicateDeps [PackageIdentifier]-                    | MissingDep    Dependency-                    | ExtraDep      PackageIdentifier-                    | InvalidDep    Dependency PackageIdentifier--showPackageProblem :: PackageProblem -> String-showPackageProblem (DuplicateFlag (FlagName flag)) =-  "duplicate flag in the flag assignment: " ++ flag--showPackageProblem (MissingFlag (FlagName flag)) =-  "missing an assignment for the flag: " ++ flag--showPackageProblem (ExtraFlag (FlagName flag)) =-  "extra flag given that is not used by the package: " ++ flag--showPackageProblem (DuplicateDeps pkgids) =-     "duplicate packages specified as selected dependencies: "-  ++ intercalate ", " (map display pkgids)--showPackageProblem (MissingDep dep) =-     "the package has a dependency " ++ display dep-  ++ " but no package has been selected to satisfy it."--showPackageProblem (ExtraDep pkgid) =-     "the package configuration specifies " ++ display pkgid-  ++ " but (with the given flag assignment) the package does not actually"-  ++ " depend on any version of that package."--showPackageProblem (InvalidDep dep pkgid) =-     "the package depends on " ++ display dep-  ++ " but the configuration specifies " ++ display pkgid-  ++ " which does not satisfy the dependency."--configuredPackageProblems :: OS -> Arch -> CompilerId-                          -> ConfiguredPackage -> [PackageProblem]-configuredPackageProblems os arch comp-  (ConfiguredPackage pkg specifiedFlags specifiedDeps) =-     [ DuplicateFlag flag | ((flag,_):_) <- duplicates specifiedFlags ]-  ++ [ MissingFlag flag | OnlyInLeft  flag <- mergedFlags ]-  ++ [ ExtraFlag   flag | OnlyInRight flag <- mergedFlags ]-  ++ [ DuplicateDeps pkgs-     | pkgs <- duplicatesBy (comparing packageName) specifiedDeps ]-  ++ [ MissingDep dep       | OnlyInLeft  dep       <- mergedDeps ]-  ++ [ ExtraDep       pkgid | OnlyInRight     pkgid <- mergedDeps ]-  ++ [ InvalidDep dep pkgid | InBoth      dep pkgid <- mergedDeps-                            , not (packageSatisfiesDependency pkgid dep) ]-  where-    mergedFlags = mergeBy compare-      (sort $ map flagName (genPackageFlags (packageDescription pkg)))-      (sort $ map fst specifiedFlags)--    mergedDeps = mergeBy-      (\dep pkgid -> dependencyName dep `compare` packageName pkgid)-      (sortBy (comparing dependencyName) requiredDeps)-      (sortBy (comparing packageName)    specifiedDeps)--    packageSatisfiesDependency-      (PackageIdentifier name  version)-      (Dependency        name' versionRange) = assert (name == name') $-        version `withinRange` versionRange--    dependencyName (Dependency name _) = name--    requiredDeps :: [Dependency]-    requiredDeps =-      --TODO: use something lower level than finalizePackageDescription-      case finalizePackageDescription specifiedFlags-         (Nothing :: Maybe (PackageIndex PackageIdentifier)) os arch comp []-         (packageDescription pkg) of-        Right (resolvedPkg, _) -> buildDepends resolvedPkg-        Left  _ -> error "configuredPackageInvalidDeps internal error"
− Hackage/List.hs 
@@ -1,181 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Hackage.Install--- Copyright   :  (c) David Himmelstrup 2005--- License     :  BSD-like------ Maintainer  :  lemmih@gmail.com--- Stability   :  provisional--- Portability :  portable------ High level interface to package installation.-------------------------------------------------------------------------------module Hackage.List (-  list-  ) 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(..), Package(..))-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 Hackage.IndexUtils (getAvailablePackages)-import Hackage.Setup (ListFlags(..))-import Hackage.Types (AvailablePackage(..), Repo)-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 Hackage.Utils (mergeBy, MergeResult(..))---- |Show information about packages-list :: Verbosity-     -> PackageDB-     -> [Repo]-     -> Compiler-     -> ProgramConfiguration-     -> ListFlags-     -> [String]-     -> IO ()-list verbosity packageDB repos comp conf listFlags pats = do-    Just installed <- getInstalledPackages verbosity comp packageDB conf-    available <- getAvailablePackages verbosity repos-    let pkgs | null pats = (PackageIndex.allPackages installed-                           ,PackageIndex.allPackages available)-             | otherwise =-                 (concatMap (PackageIndex.searchByNameSubstring installed) pats-                 ,concatMap (PackageIndex.searchByNameSubstring available) pats)-        matches = installedFilter-                . map (uncurry mergePackageInfo)-                $ uncurry mergePackages pkgs--    if simpleOutput-      then putStr $ unlines-             [ name pkg ++ " " ++ display version-             | pkg <- matches-             , version <- if onlyInstalled-                            then              installedVersions pkg-                            else nub . sort $ installedVersions pkg-                                           ++ availableVersions pkg ]-      else-        if null matches-            then notice verbosity "No matches found."-            else putStr $ unlines (map showPackageInfo matches)-  where-    installedFilter-      | onlyInstalled = filter (not . null . installedVersions)-      | otherwise     = id-    onlyInstalled = fromFlag (listInstalled listFlags)-    simpleOutput  = fromFlag (listSimpleOutput listFlags)---- | 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              :: String,-    installedVersions :: [Version],-    availableVersions :: [Version],-    homepage          :: String,-    category          :: String,-    synopsis          :: String,-    license           :: License-  }--showPackageInfo :: PackageDisplayInfo -> String-showPackageInfo pkg =-  renderStyle (style {lineLength = 80, ribbonsPerLine = 1}) $-     text " *" <+> text (name pkg)-     $+$-     (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))-     ])-     $+$ 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---- | We get the 'PackageDisplayInfo' by combining the info for the installed--- and available versions of a package.------ * We're building info about a various versions of a single named package so--- the input package info records are all supposed to refer to the same--- package name.----mergePackageInfo :: [InstalledPackageInfo]-                 -> [AvailablePackage]-                 -> PackageDisplayInfo-mergePackageInfo installed available =-  assert (length installed + length available > 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-  }-  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))---- | Rearrange installed and available packages into groups referring to the--- same package by name. In the result pairs, the lists are guaranteed to not--- both be empty.----mergePackages ::   [InstalledPackageInfo] -> [AvailablePackage]-              -> [([InstalledPackageInfo],   [AvailablePackage])]-mergePackages installed available =-    map collect-  $ mergeBy (\i a -> fst i `compare` fst a)-            (groupOn (pkgName . packageId) installed)-            (groupOn (pkgName . packageId) available)-  where-    collect (OnlyInLeft  (_,is)       ) = (is, [])-    collect (    InBoth  (_,is) (_,as)) = (is, as)-    collect (OnlyInRight        (_,as)) = ([], as)--groupOn :: Ord key => (a -> key) -> [a] -> [(key,[a])]-groupOn key = map (\xs -> (key (head xs), xs))-            . groupBy (equating key)-            . sortBy (comparing key)
− Hackage/ParseUtils.hs 
@@ -1,82 +0,0 @@-module Hackage.ParseUtils where--import Distribution.Compat.ReadP-         ( ReadP, readP_to_S, pfail, get, look, choice, (+++) )-import Distribution.Package (PackageIdentifier(..), Dependency(..))-import Distribution.ParseUtils -         ( Field(..), FieldDescr(..), ParseResult(..), PError-         , field, liftField, readFields-         , warning, lineNo, locatedErrorMsg)-import Distribution.Text-         ( Text(parse) )-import Distribution.Version (Version(..), VersionRange(..))--import Control.Monad (foldM, liftM)-import Data.Char (isSpace, toLower)-import Data.Maybe (listToMaybe)-import Text.PrettyPrint.HughesPJ (Doc, render, vcat, text, (<>), (<+>))---showPError :: PError -> String-showPError err = let (ml,msg) = locatedErrorMsg err-                  in maybe "" (\l -> "On line " ++ show l ++ ": ") ml ++ msg----readPToMaybe :: ReadP a a -> String -> Maybe a-readPToMaybe p str = listToMaybe [ r | (r,s) <- readP_to_S p str, all isSpace s ]--ignoreWarnings :: ParseResult a -> ParseResult a-ignoreWarnings (ParseOk _ x) = ParseOk [] x-ignoreWarnings r = r --parseBasicStanza :: [FieldDescr a] -> a -> String -> ParseResult a-parseBasicStanza fields empty inp = -    readFields inp >>= foldM (setField fields) empty--setField :: [FieldDescr a]-         -> a-         -> Field-         -> ParseResult a-setField fs x (F line f val) =-    case lookupFieldDescr fs f of-      Nothing -> -          do warning ("Unrecognized field " ++ f ++ " on line " ++ show line)-             return x-      Just (FieldDescr _ _ set) -> set line val x-setField _ x s = -    do warning ("Unrecognized stanza on line " ++ show (lineNo s))-       return x--lookupFieldDescr :: [FieldDescr a] -> String -> Maybe (FieldDescr a)-lookupFieldDescr fs n = listToMaybe [f | f@(FieldDescr name _ _) <- fs, name == n]--boolField :: String -> (a -> Bool) -> (Bool -> a -> a) -> FieldDescr a-boolField name g s = liftField g s $ field name showBool readBool-  where-    showBool :: Bool -> Doc-    showBool True = text "true"-    showBool False = text "false"--    readBool :: ReadP r Bool-    readBool = choice [ stringNoCase "true"  >> return True-                      , stringNoCase "false" >> return False-                      , stringNoCase "yes"   >> return True-                      , stringNoCase "no"    >> return False]--showFields :: [FieldDescr a] -> a -> String-showFields fs x = render $ vcat [ text name <> text ":" <+> g x | FieldDescr name g _ <- fs]---stringNoCase :: String -> ReadP r String-stringNoCase this = look >>= scan this- where-  scan []     _                               = return this-  scan (x:xs) (y:ys) | toLower x == toLower y = get >> scan xs ys-  scan _      _                               = pfail--parseDependencyOrPackageId :: ReadP r Dependency-parseDependencyOrPackageId = parse +++ liftM pkgToDep parse-  where pkgToDep p = case pkgVersion p of-          Version [] _ -> Dependency (pkgName p) AnyVersion-          version      -> Dependency (pkgName p) (ThisVersion version)
− Hackage/Reporting.hs 
@@ -1,318 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Hackage.Reporting--- Copyright   :  (c) David Waern 2008--- License     :  BSD-like------ Maintainer  :  david.waern@gmail.com--- Stability   :  experimental--- Portability :  portable------ Report data structure----------------------------------------------------------------------------------module Hackage.Reporting (-    BuildReport(..),-    InstallOutcome(..),-    Outcome(..),--    -- * Constructing and writing reports-    buildReport,-    writeBuildReports,--    -- * parsing and pretty printing-    parseBuildReport,-    parseBuildReports,-    showBuildReport,--    -- * 'InstallPlan' variants-    planPackageBuildReport,-    installPlanBuildReports,-    writeInstallPlanBuildReports-  ) where--import Hackage.Types-         ( ConfiguredPackage(..), AvailablePackage(..)-         , AvailablePackageSource(..), BuildResult-         , Repo(repoCacheDir), repoName )-import qualified Hackage.Types as BR-         ( BuildResult(..) )-import qualified Hackage.InstallPlan as InstallPlan-import Hackage.InstallPlan-         ( InstallPlan, PlanPackage )-import Hackage.ParseUtils-         ( showFields, parseBasicStanza )-import qualified Paths_cabal_install (version)--import Distribution.Package-         ( PackageIdentifier(PackageIdentifier), Package(packageId) )-import Distribution.PackageDescription-         ( FlagName(..), FlagAssignment )---import Distribution.Version---         ( Version )-import Distribution.System-         ( OS, Arch )-import Distribution.Compiler-         ( CompilerId )-import Distribution.Text-         ( Text(disp, parse) )-import Distribution.ParseUtils-         ( FieldDescr(..), ParseResult(..), simpleField, listField )-import qualified Distribution.Compat.ReadP as Parse-         ( ReadP, pfail, munch1, char, option, skipSpaces )-import Text.PrettyPrint.HughesPJ as Disp-         ( Doc, char, text, (<+>), (<>) )-import Distribution.Simple.Utils-         ( comparing, equating )--import Data.List-         ( unfoldr, groupBy, sortBy )-import Data.Maybe-         ( catMaybes )-import Data.Char as Char-         ( isAlpha, isAlphaNum )-import System.FilePath-         ( (</>) )--data BuildReport-   = BuildReport {-    -- | The package this build report is about-    package         :: PackageIdentifier,--    -- | The OS and Arch the package was built on-    os              :: OS,-    arch            :: Arch,--    -- | The Haskell compiler (and hopefully version) used-    compiler        :: CompilerId,--    -- | The uploading client, ie cabal-install-x.y.z-    client          :: PackageIdentifier,--    -- | Which configurations flags we used-    flagAssignment  :: FlagAssignment,--    -- | Which dependent packages we were using exactly-    dependencies    :: [PackageIdentifier],--    -- | Did installing work ok?-    installOutcome  :: InstallOutcome,--    -- | Which version of the Cabal library was used to compile the Setup.hs---    cabalVersion    :: Version,--    -- | Which build tools we were using (with versions)---    tools      :: [PackageIdentifier],--    -- | Configure outcome, did configure work ok?-    docsOutcome     :: Outcome,--    -- | Configure outcome, did configure work ok?-    testsOutcome    :: Outcome-  }--data InstallOutcome-   = DependencyFailed PackageIdentifier-   | DownloadFailed-   | UnpackFailed-   | SetupFailed-   | ConfigureFailed-   | BuildFailed-   | InstallFailed-   | InstallOk--data Outcome = NotTried | Failed | Ok--writeBuildReports :: [(BuildReport, Repo)] -> IO ()-writeBuildReports reports = sequence_-  [ appendFile file (concatMap format reports')-  | (repo, reports') <- separate reports-  , let file = repoCacheDir repo </> "build-reports.log" ]-  --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)--  where-    format r = '\n' : showBuildReport r ++ "\n"-    separate :: [(BuildReport, Repo)] -> [(Repo, [BuildReport])]-    separate = map (\rs@((_,repo):_) -> (repo, map fst rs))-             . map concat-             . groupBy (equating (repoName . snd . head))-             . sortBy (comparing (repoName . snd . head))-             . groupBy (equating (repoName . snd))--buildReport :: OS -> Arch -> CompilerId -- -> Version-            -> ConfiguredPackage -> BR.BuildResult-            -> BuildReport-buildReport os' arch' comp (ConfiguredPackage pkg flags deps) result =-  BuildReport {-    package               = packageId pkg,-    os                    = os',-    arch                  = arch',-    compiler              = comp,-    client                = cabalInstallID,-    flagAssignment        = flags,-    dependencies          = deps,-    installOutcome        = case result of-    BR.DependentFailed p -> DependencyFailed p-    BR.UnpackFailed _    -> UnpackFailed-    BR.ConfigureFailed _ -> ConfigureFailed-    BR.BuildFailed _     -> BuildFailed-    BR.InstallFailed _   -> InstallFailed-    BR.BuildOk           -> InstallOk,---    cabalVersion          = undefined-    docsOutcome           = NotTried,-    testsOutcome          = NotTried-  }-  where-    cabalInstallID =-      PackageIdentifier "cabal-install" Paths_cabal_install.version---- --------------------------------------------------------------- * External format--- --------------------------------------------------------------initialBuildReport :: BuildReport-initialBuildReport = BuildReport {-    package         = requiredField "package",-    os              = requiredField "os",-    arch            = requiredField "arch",-    compiler        = requiredField "compiler",-    client          = requiredField "client",-    flagAssignment  = [],-    dependencies    = [],-    installOutcome  = requiredField "install-outcome",---    cabalVersion  = Nothing,---    tools         = [],-    docsOutcome     = NotTried,-    testsOutcome    = NotTried-  }-  where-    requiredField fname = error ("required field: " ++ fname)---- -------------------------------------------------------------------------------- Parsing--parseBuildReport :: String -> ParseResult BuildReport-parseBuildReport = parseBasicStanza fieldDescrs initialBuildReport--parseBuildReports :: String -> [BuildReport]-parseBuildReports str =-  [ report | ParseOk [] report <- map parseBuildReport (split str) ]--  where-    split :: String -> [String]-    split = filter (not . null) . unfoldr chunk . lines-    chunk [] = Nothing-    chunk ls = case break null ls of-                 (r, rs) -> Just (unlines r, dropWhile null rs)---- -------------------------------------------------------------------------------- Pretty-printing--showBuildReport :: BuildReport -> String-showBuildReport = showFields fieldDescrs---- -------------------------------------------------------------------------------- Description of the fields, for parsing/printing--fieldDescrs :: [FieldDescr BuildReport]-fieldDescrs =- [ simpleField "package"         disp           parse-                                 package        (\v r -> r { package = v })- , simpleField "os"              disp           parse-                                 os             (\v r -> r { os = v })- , simpleField "arch"            disp           parse-                                 arch           (\v r -> r { arch = v })- , simpleField "compiler"        disp           parse-                                 compiler       (\v r -> r { compiler = v })- , simpleField "client"          disp           parse-                                 client         (\v r -> r { client = v })- , listField   "flags"           dispFlag       parseFlag-                                 flagAssignment (\v r -> r { flagAssignment = v })- , listField   "dependencies"    disp           parse-                                 dependencies   (\v r -> r { dependencies = v })- , simpleField "install-outcome" disp           parse-                                 installOutcome (\v r -> r { installOutcome = v })- , simpleField "docs-outcome"    disp           parse-                                 docsOutcome    (\v r -> r { docsOutcome = v })- , simpleField "tests-outcome"   disp           parse-                                 testsOutcome   (\v r -> r { testsOutcome = v })- ]--dispFlag :: (FlagName, Bool) -> Disp.Doc-dispFlag (FlagName name, True)  =                  Disp.text name-dispFlag (FlagName name, False) = Disp.char '-' <> Disp.text name--parseFlag :: Parse.ReadP r (FlagName, Bool)-parseFlag = do-  value <- Parse.option True (Parse.char '-' >> return False)-  name  <- Parse.munch1 (\c -> Char.isAlphaNum c || c == '_' || c == '-')-  return (FlagName name, value)--instance Text InstallOutcome where-  disp (DependencyFailed pkgid) = Disp.text "DependencyFailed" <+> disp pkgid-  disp DownloadFailed  = Disp.text "DownloadFailed"-  disp UnpackFailed    = Disp.text "UnpackFailed"-  disp SetupFailed     = Disp.text "SetupFailed"-  disp ConfigureFailed = Disp.text "ConfigureFailed"-  disp BuildFailed     = Disp.text "BuildFailed"-  disp InstallFailed   = Disp.text "InstallFailed"-  disp InstallOk       = Disp.text "InstallOk"--  parse = do-    name <- Parse.munch1 Char.isAlphaNum-    case name of-      "DependencyFailed" -> do Parse.skipSpaces-                               pkgid <- parse-                               return (DependencyFailed pkgid)-      "DownloadFailed"   -> return DownloadFailed-      "UnpackFailed"     -> return UnpackFailed-      "SetupFailed"      -> return SetupFailed-      "ConfigureFailed"  -> return ConfigureFailed-      "BuildFailed"      -> return BuildFailed-      "InstallFailed"    -> return InstallFailed-      "InstallOk"        -> return InstallOk-      _                  -> Parse.pfail--instance Text Outcome where-  disp NotTried = Disp.text "NotTried"-  disp Failed   = Disp.text "Failed"-  disp Ok       = Disp.text "Ok"-  parse = do-    name <- Parse.munch1 Char.isAlpha-    case name of-      "NotTried" -> return NotTried-      "Failed"   -> return Failed-      "Ok"       -> return Ok-      _          -> Parse.pfail---- --------------------------------------------------------------- * InstallPlan support--- --------------------------------------------------------------writeInstallPlanBuildReports :: InstallPlan BuildResult -> IO ()-writeInstallPlanBuildReports = writeBuildReports . installPlanBuildReports--installPlanBuildReports :: InstallPlan BuildResult -> [(BuildReport, Repo)]-installPlanBuildReports plan = catMaybes-                             . map (planPackageBuildReport os' arch' comp)-                             . InstallPlan.toList-                             $ plan-  where os'   = InstallPlan.planOS plan-        arch' = InstallPlan.planArch plan-        comp  = InstallPlan.planCompiler plan--planPackageBuildReport :: OS -> Arch -> CompilerId-                       -> InstallPlan.PlanPackage BuildResult-                       -> Maybe (BuildReport, Repo)-planPackageBuildReport os' arch' comp planPackage = case planPackage of--  InstallPlan.Installed pkg@(ConfiguredPackage (AvailablePackage {-                          packageSource = RepoTarballPackage repo }) _ _)-    -> Just $ (buildReport os' arch' comp pkg BR.BuildOk, repo)--  InstallPlan.Failed pkg@(ConfiguredPackage (AvailablePackage {-                       packageSource = RepoTarballPackage repo }) _ _) result-    -> Just $ (buildReport os' arch' comp pkg result, repo)--  _ -> Nothing
− Hackage/Setup.hs 
@@ -1,370 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Hackage.Setup--- Copyright   :  (c) David Himmelstrup 2005--- License     :  BSD-like------ Maintainer  :  lemmih@gmail.com--- Stability   :  provisional--- Portability :  portable-------------------------------------------------------------------------------------module Hackage.Setup-    ( globalCommand, Cabal.GlobalFlags(..)-    , configureCommand, filterConfigureFlags-    , installCommand, InstallFlags(..)-    , listCommand, ListFlags(..)-    , updateCommand-    , upgradeCommand-    , infoCommand-    , fetchCommand-    , checkCommand-    , uploadCommand, UploadFlags(..)--    , parsePackageArgs-    ) where--import Distribution.Simple.Program (defaultProgramConfiguration)-import Distribution.Simple.Command-import qualified Distribution.Simple.Setup as Cabal-  (GlobalFlags(..),  {-emptyGlobalFlags,-}   globalCommand,-  ConfigFlags(..),   {-emptyConfigFlags,-}   configureCommand,-{-  CopyFlags(..),     emptyCopyFlags,     copyCommand,-  InstallFlags(..),  emptyInstallFlags,  installCommand,-  HaddockFlags(..),  emptyHaddockFlags,  haddockCommand,-  HscolourFlags(..), emptyHscolourFlags, hscolourCommand,-  BuildFlags(..),    emptyBuildFlags,    buildCommand,-  CleanFlags(..),    emptyCleanFlags,    cleanCommand,-  PFEFlags(..),      emptyPFEFlags,      programaticaCommand,-  MakefileFlags(..), emptyMakefileFlags, makefileCommand,-  RegisterFlags(..), emptyRegisterFlags, registerCommand, unregisterCommand,-  SDistFlags(..),    emptySDistFlags,    sdistCommand,-                                         testCommand-})-import Distribution.Simple.Setup-         ( Flag(..), toFlag, flagToList, trueArg, optionVerbosity )-import Distribution.Version-         ( Version(Version) )-import Distribution.Package-         ( Dependency )-import Distribution.Text-         ( Text(parse), display )-import Distribution.ReadE-         ( readP_to_E )-import Distribution.Verbosity (Verbosity, normal)--import Hackage.Types-         ( Username(..), Password(..) )-import Hackage.ParseUtils (readPToMaybe, parseDependencyOrPackageId)--import Data.Monoid (Monoid(..))--globalCommand :: CommandUI Cabal.GlobalFlags-globalCommand = Cabal.globalCommand {-    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"-  }--configureCommand :: CommandUI Cabal.ConfigFlags-configureCommand = (Cabal.configureCommand defaultProgramConfiguration) {-    commandDefaultFlags = mempty-  }--filterConfigureFlags :: Cabal.ConfigFlags -> Version -> Cabal.ConfigFlags-filterConfigureFlags flags cabalLibVersion-  | cabalLibVersion >= Version [1,3,10] [] = flags-    -- older Cabal does not grok the constraints flag:-  | otherwise = flags { Cabal.configConstraints = [] }---fetchCommand :: CommandUI (Flag Verbosity)-fetchCommand = CommandUI {-    commandName         = "fetch",-    commandSynopsis     = "Downloads packages for later installation or study.",-    commandDescription  = Nothing,-    commandUsage        = usagePackages "fetch",-    commandDefaultFlags = toFlag normal,-    commandOptions      = \_ -> [optionVerbosity id const]-  }--updateCommand  :: CommandUI (Flag Verbosity)-updateCommand = CommandUI {-    commandName         = "update",-    commandSynopsis     = "Updates list of known packages",-    commandDescription  = Nothing,-    commandUsage        = usagePackages "update",-    commandDefaultFlags = toFlag normal,-    commandOptions      = \_ -> [optionVerbosity id const]-  }--upgradeCommand  :: CommandUI (Cabal.ConfigFlags, InstallFlags)-upgradeCommand = configureCommand {-    commandName         = "upgrade",-    commandSynopsis     = "Upgrades installed packages to the latest available version",-    commandDescription  = Nothing,-    commandUsage        = usagePackages "upgrade",-    commandDefaultFlags = (mempty, defaultInstallFlags),-    commandOptions      = \showOrParseArgs ->-         liftOptionsFst (commandOptions configureCommand showOrParseArgs)-      ++ liftOptionsSnd [optionDryRun]-  }--{--cleanCommand  :: CommandUI ()-cleanCommand = makeCommand name shortDesc longDesc emptyFlags options-  where-    name       = "clean"-    shortDesc  = "Removes downloaded files"-    longDesc   = Nothing-    emptyFlags = ()-    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",-    commandSynopsis     = "Check the package for common mistakes",-    commandDescription  = Nothing,-    commandUsage        = \pname -> "Usage: " ++ pname ++ " check\n",-    commandDefaultFlags = mempty,-    commandOptions      = mempty-  }---- --------------------------------------------------------------- * List flags--- --------------------------------------------------------------data ListFlags = ListFlags {-    listInstalled :: Flag Bool,-    listSimpleOutput :: Flag Bool,-    listVerbosity :: Flag Verbosity-  }--defaultListFlags :: ListFlags-defaultListFlags = ListFlags {-    listInstalled = Flag False,-    listSimpleOutput = Flag False,-    listVerbosity = toFlag normal-  }--listCommand  :: CommandUI ListFlags-listCommand = CommandUI {-    commandName         = "list",-    commandSynopsis     = "List available packages on the server (cached).",-    commandDescription  = Nothing,-    commandUsage        = usagePackages "list",-    commandDefaultFlags = defaultListFlags,-    commandOptions      = \_ -> [-        optionVerbosity listVerbosity (\v flags -> flags { listVerbosity = v })--        , option [] ["installed"]-            "Only print installed packages"-            listInstalled (\v flags -> flags { listInstalled = v })-            trueArg--        , option [] ["simple-output"]-            "Print in a easy-to-parse format"-            listSimpleOutput (\v flags -> flags { listSimpleOutput = v })-            trueArg--        ]-  }--instance Monoid ListFlags where-  mempty = defaultListFlags-  mappend a b = ListFlags {-    listInstalled = combine listInstalled,-    listSimpleOutput = combine listSimpleOutput,-    listVerbosity = combine listVerbosity-  }-    where combine field = field a `mappend` field b---- --------------------------------------------------------------- * Install flags--- ---------------------------------------------------------------- | Install takes the same flags as configure along with a few extras.----data InstallFlags = InstallFlags {-    installDryRun       :: Flag Bool,-    installOnly         :: Flag Bool,-    installRootCmd      :: Flag String,-    installCabalVersion :: Flag Version-  }--defaultInstallFlags :: InstallFlags-defaultInstallFlags = InstallFlags {-    installDryRun       = Flag False,-    installOnly         = Flag False,-    installRootCmd      = mempty,-    installCabalVersion = mempty-  }--installCommand :: CommandUI (Cabal.ConfigFlags, InstallFlags)-installCommand = configureCommand {-    commandName         = "install",-    commandSynopsis     = "Installs a list of packages.",-    commandUsage        = usagePackages "install",-    commandDefaultFlags = (mempty, defaultInstallFlags),-    commandOptions      = \showOrParseArgs ->-         liftOptionsFst (commandOptions configureCommand showOrParseArgs)-      ++ liftOptionsSnd -             (optionDryRun-             :optionRootCmd-             :optionCabalVersion-             :case showOrParseArgs of      -- TODO: remove when "cabal install" avoids-                ParseArgs -> [optionOnly]  -- reconfiguring/building with dep. analysis-                _         -> [])           -- It's used by --root-cmd.--  }--optionDryRun :: OptionField InstallFlags-optionDryRun =-  option [] ["dry-run"]-    "Do not install anything, only print what would be installed."-    installDryRun (\v flags -> flags { installDryRun = v })-    trueArg--optionOnly :: OptionField InstallFlags-optionOnly =-  option [] ["only"]-    "Only installs the package in the current directory."-    installOnly (\v flags -> flags { installOnly = v })-    trueArg--optionRootCmd :: OptionField InstallFlags-optionRootCmd =-  option [] ["root-cmd"]-    "Command used to gain root privileges, when installing with --global."-    installRootCmd (\v flags -> flags { installRootCmd = v })-    (reqArg' "COMMAND" toFlag flagToList)--optionCabalVersion :: OptionField InstallFlags-optionCabalVersion =-  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))--instance Monoid InstallFlags where-  mempty = defaultInstallFlags-  mappend a b = InstallFlags {-    installDryRun       = combine installDryRun,-    installOnly         = combine installOnly,-    installRootCmd      = combine installRootCmd,-    installCabalVersion = combine installCabalVersion-  }-    where combine field = field a `mappend` field b---- --------------------------------------------------------------- * Upload flags--- --------------------------------------------------------------data UploadFlags = UploadFlags {-    uploadCheck     :: Flag Bool,-    uploadUsername  :: Flag Username,-    uploadPassword  :: Flag Password,-    uploadVerbosity :: Flag Verbosity-  }--defaultUploadFlags :: UploadFlags-defaultUploadFlags = UploadFlags {-    uploadCheck     = toFlag False,-    uploadUsername  = mempty,-    uploadPassword  = mempty,-    uploadVerbosity = toFlag normal-  }--uploadCommand :: CommandUI UploadFlags-uploadCommand = CommandUI {-    commandName         = "upload",-    commandSynopsis     = "Uploads source packages to Hackage",-    commandDescription  = Just $ \_ ->-         "You can store your Hackage login in " ++ "FIXME: configFile"-      ++ "\nusing the format (\"username\",\"password\").\n",-    commandUsage        = \pname ->-         "Usage: " ++ pname ++ " upload [FLAGS] [TARFILES]\n\n"-      ++ "Flags for upload:",-    commandDefaultFlags = defaultUploadFlags,-    commandOptions      = \_ ->-      [optionVerbosity uploadVerbosity (\v flags -> flags { uploadVerbosity = v })--      ,option ['c'] ["check"]-         "Do not upload, just do QA checks."-        uploadCheck (\v flags -> flags { uploadCheck = v })-        trueArg--      ,option ['u'] ["username"]-        "Hackage username."-        uploadUsername (\v flags -> flags { uploadUsername = v })-        (reqArg' "USERNAME" (toFlag . Username)-                            (flagToList . fmap unUsername))--      ,option ['p'] ["password"]-        "Hackage password."-        uploadPassword (\v flags -> flags { uploadPassword = v })-        (reqArg' "PASSWORD" (toFlag . Password)-                            (flagToList . fmap unPassword))-      ]-  }--instance Monoid UploadFlags where-  mempty = UploadFlags {-    uploadCheck     = mempty,-    uploadUsername  = mempty,-    uploadPassword  = mempty,-    uploadVerbosity = mempty-  }-  mappend a b = UploadFlags {-    uploadCheck     = combine uploadCheck,-    uploadUsername  = combine uploadUsername,-    uploadPassword  = combine uploadPassword,-    uploadVerbosity = combine uploadVerbosity-  }-    where combine field = field a `mappend` field b---- --------------------------------------------------------------- * GetOpt Utils--- --------------------------------------------------------------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)))--usagePackages :: String -> String -> String-usagePackages name pname =-     "Usage: " ++ pname ++ " " ++ name ++ " [FLAGS]\n"-  ++ "   or: " ++ pname ++ " " ++ name ++ " [PACKAGES]\n\n"-  ++ "Flags for " ++ name ++ ":"----TODO: do we want to allow per-package flags?-parsePackageArgs :: [String] -> Either String [Dependency]-parsePackageArgs = parsePkgArgs []-  where-    parsePkgArgs ds [] = Right (reverse ds)-    parsePkgArgs ds (arg:args) =-      case readPToMaybe parseDependencyOrPackageId arg of-        Just dep -> parsePkgArgs (dep:ds) args-        Nothing  -> Left ("Failed to parse package dependency: " ++ show arg)
− Hackage/SetupWrapper.hs 
@@ -1,300 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Hackage.SetupWrapper--- Copyright   :  (c) The University of Glasgow 2006,---                    Duncan Coutts 2008------ Maintainer  :  cabal-devel@haskell.org--- Stability   :  alpha--- Portability :  portable------ An interface to building and installing Cabal packages.--- If the @Built-Type@ field is specified as something other than--- 'Custom', and the current version of Cabal is acceptable, this performs--- setup actions directly.  Otherwise it builds the setup script and--- runs it with the given arguments.--module Hackage.SetupWrapper (-    setupWrapper,-    SetupScriptOptions(..),-    defaultSetupScriptOptions,-  ) where--import qualified Distribution.Make as Make-import qualified Distribution.Simple as Simple-import Distribution.Version-         ( Version(..), VersionRange(..), withinRange )-import Distribution.Package-         ( PackageIdentifier(..), packageName, packageVersion, Dependency(..) )-import Distribution.PackageDescription-         ( GenericPackageDescription(packageDescription)-         , PackageDescription(..), BuildType(..), readPackageDescription )-import Distribution.InstalledPackageInfo-         ( InstalledPackageInfo )-import Distribution.Simple.Configure-         ( configCompiler, getInstalledPackages )-import Distribution.Simple.Compiler-         ( CompilerFlavor(GHC), Compiler, PackageDB(..) )-import Distribution.Simple.Program-         ( ProgramConfiguration, emptyProgramConfiguration-         , rawSystemProgramConf, ghcProgram )-import Distribution.Simple.BuildPaths-         ( defaultDistPref, exeExtension )-import Distribution.Simple.Command-         ( CommandUI(..), commandShowOptions )-import Distribution.Simple.GHC-         ( ghcVerbosityOptions )-import qualified Distribution.Simple.PackageIndex as PackageIndex-import Distribution.Simple.PackageIndex (PackageIndex)-import Distribution.Simple.Utils-         ( die, debug, cabalVersion, defaultPackageDesc, comparing-         , rawSystemExit, createDirectoryIfMissingVerbose )-import Distribution.Text-         ( display )-import Distribution.Verbosity-         ( Verbosity )--import System.Directory  ( doesFileExist, getModificationTime )-import System.FilePath   ( (</>), (<.>) )-import System.IO.Error   ( isDoesNotExistError )-import Control.Monad     ( when, unless )-import Control.Exception ( evaluate )-import Data.List         ( maximumBy )-import Data.Maybe        ( fromMaybe )-import Data.Monoid       ( Monoid(mempty) )-import Data.Char         ( isSpace )--data SetupScriptOptions = SetupScriptOptions {-    useCabalVersion  :: VersionRange,-    useCompiler      :: Maybe Compiler,-    usePackageIndex  :: Maybe (PackageIndex InstalledPackageInfo),-    useProgramConfig :: ProgramConfiguration,-    useDistPref      :: FilePath-  }--defaultSetupScriptOptions :: SetupScriptOptions-defaultSetupScriptOptions = SetupScriptOptions {-    useCabalVersion  = AnyVersion,-    useCompiler      = Nothing,-    usePackageIndex  = Nothing,-    useProgramConfig = emptyProgramConfiguration,-    useDistPref      = defaultDistPref-  }--setupWrapper :: Verbosity-             -> SetupScriptOptions-             -> Maybe PackageDescription-             -> CommandUI flags-             -> (Version -> flags)-             -> [String]-             -> IO ()-setupWrapper verbosity options mpkg cmd flags extraArgs = do-  pkg <- maybe getPkg return mpkg-  let setupMethod = determineSetupMethod options' buildType'-      options'    = options {-                      useCabalVersion = IntersectVersionRanges-                                          (useCabalVersion options)-                                          (descCabalVersion pkg)-                    }-      buildType'  = fromMaybe Custom (buildType pkg)-      mkArgs cabalLibVersion = commandName cmd-                             : commandShowOptions cmd (flags cabalLibVersion)-                            ++ extraArgs-  setupMethod verbosity pkg buildType' mkArgs-  where-    getPkg = defaultPackageDesc verbosity-         >>= readPackageDescription verbosity-         >>= return . packageDescription---- | Decide if we're going to be able to do a direct internal call to the--- entry point in the Cabal library or if we're going to have to compile--- and execute an external Setup.hs script.----determineSetupMethod :: SetupScriptOptions -> BuildType -> SetupMethod-determineSetupMethod options buildType'-  | buildType' == Custom      = externalSetupMethod options-  | cabalVersion `withinRange`-      useCabalVersion options = internalSetupMethod-  | otherwise                 = externalSetupMethod options--type SetupMethod = Verbosity -> PackageDescription -> BuildType-                -> (Version -> [String]) -> IO ()---- --------------------------------------------------------------- * Internal SetupMethod--- --------------------------------------------------------------internalSetupMethod :: SetupMethod-internalSetupMethod verbosity _ bt mkargs = do-  let args = mkargs cabalVersion-  debug verbosity $ "Using internal setup method with build-type " ++ show bt-                 ++ " and args:\n  " ++ show args-  buildTypeAction bt args--buildTypeAction :: BuildType -> ([String] -> IO ())-buildTypeAction Simple    = Simple.defaultMainArgs-buildTypeAction Configure = Simple.defaultMainWithHooksArgs-                              Simple.autoconfUserHooks-buildTypeAction Make      = Make.defaultMainArgs-buildTypeAction Custom               = error "buildTypeAction Custom"-buildTypeAction (UnknownBuildType _) = error "buildTypeAction UnknownBuildType"---- --------------------------------------------------------------- * External SetupMethod--- --------------------------------------------------------------externalSetupMethod :: SetupScriptOptions -> SetupMethod-externalSetupMethod options verbosity pkg bt mkargs = do-  debug verbosity $ "Using external setup method with build-type " ++ show bt-  createDirectoryIfMissingVerbose verbosity True setupDir-  (cabalLibVersion, options') <- cabalLibVersionToUse-  debug verbosity $ "Using Cabal library version " ++ display cabalLibVersion-  setupHs <- updateSetupScript cabalLibVersion bt-  debug verbosity $ "Using " ++ setupHs ++ " as setup script."-  compileSetupExecutable options' cabalLibVersion setupHs-  invokeSetupScript (mkargs cabalLibVersion)--  where-  setupDir         = useDistPref options </> "setup"-  setupVersionFile = setupDir </> "setup" <.> "version"-  setupProgFile    = setupDir </> "setup" <.> exeExtension--  cabalLibVersionToUse :: IO (Version, SetupScriptOptions)-  cabalLibVersionToUse = do-    savedVersion <- savedCabalVersion-    case savedVersion of-      Just version | version `withinRange` useCabalVersion options-        -> return (version, options)-      _ -> do (comp, conf, options') <- configureCompiler options-              version <- installedCabalVersion options comp conf-              writeFile setupVersionFile (show version ++ "\n")-              return (version, options')--  savedCabalVersion = do-    versionString <- readFile setupVersionFile `catch` \_ -> return ""-    case reads versionString of-      [(version,s)] | all isSpace s -> return (Just version)-      _                             -> return Nothing--  installedCabalVersion :: SetupScriptOptions -> Compiler-                        -> ProgramConfiguration -> IO Version-  installedCabalVersion _ _ _ | packageName pkg == "Cabal" =-    return (packageVersion pkg)-  installedCabalVersion options' comp conf = do-    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--    let cabalDep = Dependency "Cabal" (useCabalVersion options)-    case PackageIndex.lookupDependency index cabalDep of-      []   -> die $ "The package requires Cabal library version "-                 ++ display (useCabalVersion options)-                 ++ " but no suitable version is installed."-      pkgs -> return $ bestVersion (map packageVersion pkgs)-    where-      bestVersion          = maximumBy (comparing preference)-      preference version   = (sameVersion, sameMajorVersion-                             ,stableVersion, latestVersion)-        where-          sameVersion      = version == cabalVersion-          sameMajorVersion = majorVersion version == majorVersion cabalVersion-          majorVersion     = take 2 . versionBranch-          stableVersion    = case versionBranch version of-                               (_:x:_) -> even x-                               _       -> False-          latestVersion    = version--  configureCompiler :: SetupScriptOptions-                    -> IO (Compiler, ProgramConfiguration, SetupScriptOptions)-  configureCompiler options' = do-    (comp, conf) <- case useCompiler options' of-      Just comp -> return (comp, useProgramConfig options')-      Nothing   -> configCompiler (Just GHC) Nothing Nothing-                     (useProgramConfig options') verbosity-    return (comp, conf, options' { useCompiler = Just comp,-                                   useProgramConfig = conf })--  -- | Decide which Setup.hs script to use, creating it if necessary.-  ---  updateSetupScript :: Version -> BuildType -> IO FilePath-  updateSetupScript _ Custom = do-    useHs  <- doesFileExist "Setup.hs"-    useLhs <- doesFileExist "Setup.lhs"-    unless (useHs || useLhs) $ die-      "Using 'build-type: Custom' but there is no Setup.hs or Setup.lhs script."-    return (if useHs then "Setup.hs" else "Setup.lhs")--  updateSetupScript cabalLibVersion _ = do-    rewriteFile setupHs (buildTypeScript cabalLibVersion)-    return setupHs-    where-      setupHs  = setupDir </> "setup" <.> "hs"--  buildTypeScript :: Version -> String-  buildTypeScript cabalLibVersion = case bt of-    Simple    -> "import Distribution.Simple; main = defaultMain\n"-    Configure -> "import Distribution.Simple; main = defaultMainWithHooks "-              ++ if cabalLibVersion >= Version [1,3,10] []-                   then "autoconfUserHooks\n"-                   else "defaultUserHooks\n"-    Make      -> "import Distribution.Make; main = defaultMain\n"-    Custom             -> error "buildTypeScript Custom"-    UnknownBuildType _ -> error "buildTypeScript UnknownBuildType"--  -- | If the Setup.hs is out of date wrt the executable then recompile it.-  -- Currently this is GHC only. It should really be generalised.-  ---  compileSetupExecutable :: SetupScriptOptions -> Version -> FilePath -> IO ()-  compileSetupExecutable options' cabalLibVersion setupHsFile = do-    setupHsNewer      <- setupHsFile      `moreRecentFile` setupProgFile-    cabalVersionNewer <- setupVersionFile `moreRecentFile` setupProgFile-    let outOfDate = setupHsNewer || cabalVersionNewer-    when outOfDate $ do-      debug verbosity "Setup script is out of date, compiling..."-      (_, conf, _) <- configureCompiler options'-      rawSystemProgramConf verbosity ghcProgram conf $-          ghcVerbosityOptions verbosity-       ++ ["--make", setupHsFile, "-o", setupProgFile-          ,"-odir", setupDir, "-hidir", setupDir]-       ++ if packageName pkg == "Cabal"-            then ["-i", "-i."]-            else ["-package", display cabalPkgid ]-    where cabalPkgid = PackageIdentifier "Cabal" cabalLibVersion--  invokeSetupScript :: [String] -> IO ()-  invokeSetupScript args = rawSystemExit verbosity setupProgFile args---- --------------------------------------------------------------- * Utils--- ---------------------------------------------------------------- | Compare the modification times of two files to see if the first is newer--- than the second. The first file must exist but the second need not.--- The expected use case is when the second file is generated using the first.--- In this use case, if the result is True then the second file is out of date.----moreRecentFile :: FilePath -> FilePath -> IO Bool-moreRecentFile a b = do-  exists <- doesFileExist b-  if not exists-    then return True-    else do tb <- getModificationTime b-            ta <- getModificationTime a-            return (ta > tb)---- | Write a file but only if it would have new content. If we would be writing--- the same as the existing content then leave the file as is so that we do not--- update the file's modification time.----rewriteFile :: FilePath -> String -> IO ()-rewriteFile path newContent =-  flip catch mightNotExist $ do-    existingContent <- readFile path-    evaluate (length existingContent)-    unless (existingContent == newContent) $-      writeFile path newContent-  where-    mightNotExist e | isDoesNotExistError e = writeFile path newContent-                    | otherwise             = ioError e
− Hackage/SrcDist.hs 
@@ -1,80 +0,0 @@--- Implements the \"@.\/cabal sdist@\" command, which creates a source--- distribution for this package.  That is, packs up the source code--- into a tarball, making use of the corresponding Cabal module.-module Hackage.SrcDist (-	 sdist-  )  where-import Distribution.Simple.SrcDist-         ( printPackageProblems, prepareTree, prepareSnapshotTree )-import Hackage.Tar (createTarGzFile)--import Distribution.Package-         ( Package(..) )-import Distribution.PackageDescription-         ( PackageDescription, readPackageDescription )-import Distribution.Simple.Utils-         ( withTempDirectory , defaultPackageDesc-         , die, warn, notice, setupMessage )-import Distribution.Simple.Setup (SDistFlags(..), fromFlag)-import Distribution.Verbosity (Verbosity)-import Distribution.Simple.PreProcess (knownSuffixHandlers)-import Distribution.Simple.BuildPaths ( srcPref)-import Distribution.Simple.Configure(maybeGetPersistBuildConfig)-import Distribution.PackageDescription.Configuration ( flattenPackageDescription )-import Distribution.Text-         ( display )--import System.Time (getClockTime, toCalendarTime)-import System.FilePath ((</>), (<.>))-import System.Directory (doesDirectoryExist)-import Control.Monad (when)-import Data.Maybe (isNothing)---- |Create a source distribution.-sdist :: SDistFlags -> IO ()-sdist flags = do-  pkg <- return . flattenPackageDescription-     =<< readPackageDescription verbosity-     =<< defaultPackageDesc verbosity-  mb_lbi <- maybeGetPersistBuildConfig distPref-  let tmpDir = 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--    setupMessage verbosity "Building source dist for" (packageId pkg)-    if snapshot-      then getClockTime >>= toCalendarTime-       >>= prepareSnapshotTree verbosity pkg mb_lbi-                               distPref tmpDir knownSuffixHandlers-      else prepareTree         verbosity pkg mb_lbi-                               distPref tmpDir knownSuffixHandlers-    targzFile <- createArchive verbosity pkg tmpDir distPref-    notice verbosity $ "Source tarball created: " ++ targzFile--  where-    verbosity = fromFlag (sDistVerbosity flags)-    snapshot  = fromFlag (sDistSnapshot flags)-    distPref  = fromFlag (sDistDistPref flags)---- |Create an archive from a tree of source files, and clean up the tree.-createArchive :: Verbosity-              -> PackageDescription-              -> FilePath-              -> FilePath-              -> IO FilePath-createArchive _verbosity pkg tmpDir targetPref = do-  let tarBallName     = display (packageId pkg)-      tarBallFilePath = targetPref </> tarBallName <.> "tar.gz"-  createTarGzFile tarBallFilePath tmpDir tarBallName-  return tarBallFilePath
− Hackage/Tar.hs 
@@ -1,385 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Hackage.Check--- Copyright   :  (c) 2007 Bjorn Bringert, 2008 Andrea Vezzosi--- License     :  BSD-like------ Maintainer  :  duncan@haskell.org--- Stability   :  provisional--- Portability :  portable------ Simplistic TAR archive reading and writing------ Only handles the file names and file contents, ignores other file metadata.----------------------------------------------------------------------------------module Hackage.Tar (-  TarHeader(..),-  TarFileType(..),-  readTarArchive,-  extractTarGzFile,-  createTarGzFile-  ) where--import qualified Data.ByteString.Lazy as BS-import qualified Data.ByteString.Lazy.Char8 as BS.Char8-import Data.ByteString.Lazy (ByteString)-import Data.Bits ((.&.),(.|.))-import Data.Char (ord)-import Data.Int (Int8, Int64)-import Data.List (unfoldr,partition,foldl')-import Data.Maybe (catMaybes)-import Numeric (readOct,showOct)-import System.Directory-         ( getDirectoryContents, doesFileExist, doesDirectoryExist-         , getModificationTime,  createDirectoryIfMissing, copyFile-         , Permissions(..), setPermissions, getPermissions )-import System.Time (ClockTime(..))-import System.FilePath as FilePath-         ( (</>), isValid, isAbsolute, splitFileName, splitDirectories, makeRelative )-import qualified System.FilePath.Posix as FilePath.Posix-         ( joinPath, pathSeparator )-import System.Posix.Types (FileMode)-import System.IO-         ( Handle, IOMode(ReadMode), openBinaryFile, hFileSize, hClose )-import System.IO.Unsafe (unsafeInterleaveIO)-import Control.Monad (liftM,when)-import Distribution.Simple.Utils (die)---- GNU gzip-import qualified Codec.Compression.GZip as GZip-         ( decompress, compress )---- Or use Ian's gunzip:--- import Codec.Compression.GZip.GUnZip (gunzip)--data TarHeader = TarHeader {-                    tarFileName   :: FilePath,-                    tarFileMode   :: FileMode,-                    tarFileType   :: TarFileType,-                    tarLinkTarget :: FilePath-                   } deriving Show--data TarFileType = TarNormalFile-                 | TarHardLink-                 | TarSymbolicLink-                 | TarDirectory-                 | TarOther Char-                  deriving (Eq,Show)--readTarArchive :: ByteString -> [(TarHeader,ByteString)]-readTarArchive = catMaybes . unfoldr getTarEntry--extractTarArchive :: FilePath -> [(TarHeader,ByteString)] -> IO ()-extractTarArchive dir tar = extract files >> extract links-    where-    extract = mapM_ (uncurry (extractEntry dir))-    -- TODO: does this cause a memory leak?-    (files, links) = partition (not . isLink . tarFileType . fst) tar-    isLink TarHardLink     = True-    isLink TarSymbolicLink = True-    isLink _               = False--extractTarGzFile :: FilePath -- ^ Destination directory-                 -> FilePath -- ^ Tarball-                 -> IO ()-extractTarGzFile dir file =-  extractTarArchive dir . readTarArchive . GZip.decompress =<< BS.readFile file------- * Extracting-----extractEntry :: FilePath -> TarHeader -> ByteString -> IO ()-extractEntry dir hdr cnt-    = do path <- relativizePath dir (tarFileName hdr)-         let setPerms   = setPermissions path (fileModeToPermissions (tarFileMode hdr))-             copyLinked =-                let (base, _) = splitFileName path-                    sourceName = base </> tarLinkTarget hdr-                in copyFile sourceName path-         case tarFileType hdr of-           TarNormalFile   -> BS.writeFile path cnt >> setPerms-           TarHardLink     -> copyLinked >> setPerms-           TarSymbolicLink -> copyLinked-           TarDirectory    -> createDirectoryIfMissing False path >> setPerms-           TarOther _      -> return () -- FIXME: warning?--relativizePath :: Monad m => FilePath -> FilePath -> m FilePath-relativizePath dir file-    | isAbsolute file    = fail $ "Absolute file name in TAR archive: " ++ show file-    | not (isValid file) = fail $ "Invalid file name in TAR archive: " ++ show file-    | otherwise          = return $ dir </> file--fileModeToPermissions :: FileMode -> Permissions-fileModeToPermissions m = -    Permissions {-                 readable   = m .&. ownerReadMode    /= 0,-                 writable   = m .&. ownerWriteMode   /= 0,-                 executable = m .&. ownerExecuteMode /= 0,-                 searchable = m .&. ownerExecuteMode /= 0-                }--ownerReadMode    :: FileMode-ownerReadMode    = 0o000400--ownerWriteMode   :: FileMode-ownerWriteMode   = 0o000200--ownerExecuteMode :: FileMode-ownerExecuteMode = 0o000100------- * Reading-----getTarEntry :: ByteString -> Maybe (Maybe (TarHeader,ByteString), ByteString)-getTarEntry bs | endBlock = Nothing-               | BS.length hdr < 512 = error "Truncated TAR archive."-               | not (checkChkSum hdr chkSum) = error "TAR checksum error."-               | otherwise = Just (Just (info, cnt), bs''')--   where (hdr,bs') = BS.splitAt 512 bs--         endBlock  = getByte 0 hdr == '\0'--         fileSuffix = getString   0 100 hdr-         mode       = getOct    100   8 hdr-         chkSum     = getOct    148   8 hdr-         typ        = getByte   156     hdr-         size       = getOct    124  12 hdr-         linkTarget = getString 157 100 hdr-         filePrefix = getString 345 155 hdr--         padding    = (512 - size) `mod` 512-         (cnt,bs'') = BS.splitAt size bs'-         bs'''      = BS.drop padding bs''--         fileType   = case typ of-                        '\0'-> TarNormalFile-                        '0' -> TarNormalFile-                        '1' -> TarHardLink-                        '2' -> TarSymbolicLink-                        '5' -> TarDirectory-                        c   -> TarOther c-                        -         path       = filePrefix ++ fileSuffix-         info       = TarHeader { tarFileName   = path, -                                  tarFileMode   = mode,-                                  tarFileType   = fileType,-                                  tarLinkTarget = linkTarget }--checkChkSum :: ByteString -> Int -> Bool-checkChkSum hdr s = s == chkSum hdr' || s == signedChkSum hdr'-  where -    -- replace the checksum with spaces-    hdr' = BS.concat [BS.take 148 hdr, BS.Char8.replicate 8 ' ', BS.drop 156 hdr]-    -- tar.info says that Sun tar is buggy and -    -- calculates the checksum using signed chars-    chkSum = BS.Char8.foldl' (\x y -> x + ord y) 0-    signedChkSum = BS.Char8.foldl' (\x y -> x + (ordSigned y)) 0--ordSigned :: Char -> Int-ordSigned c = fromIntegral (fromIntegral (ord c) :: Int8)---- * TAR format primitive input--getOct :: Integral a => Int64 -> Int64 -> ByteString -> a-getOct off len = parseOct . getString off len-  where parseOct "" = 0-        parseOct s = case readOct s of-                       [(x,_)] -> x-                       _       -> error $ "Number format error: " ++ show s--getBytes :: Int64 -> Int64 -> ByteString -> ByteString-getBytes off len = BS.take len . BS.drop off--getByte :: Int64 -> ByteString -> Char-getByte off bs = BS.Char8.index bs off--getString :: Int64 -> Int64 -> ByteString -> String-getString off len = BS.Char8.unpack . BS.Char8.takeWhile (/='\0') . getBytes off len------- * Writing------- | Creates a tar gzipped archive, the paths in the archive will be relative--- to the base directory.----createTarGzFile :: FilePath        -- ^ Full Tarball path-                -> FilePath        -- ^ Base directory-                -> FilePath        -- ^ Directory or file to package, relative to the base dir-                -> IO ()-createTarGzFile tarFile baseDir sourceDir = do-      (entries,hs) <- fmap unzip-                    . mapM (unsafeInterleaveIO-                          . (\path -> createTarEntry path-                                      $ makeRelative baseDir path))-                  =<< recurseDirectories [baseDir </> sourceDir]-      BS.writeFile tarFile . GZip.compress . entries2Archive $ entries-      mapM_ hClose (catMaybes hs) -- TODO: the handles are explicitly closed because of a bug in bytestring-0.9.0.1,-                                  -- once we depend on a later version we can avoid this hack.--recurseDirectories :: [FilePath] -> IO [FilePath]-recurseDirectories = -    liftM concat . mapM (\p -> liftM (p:) $ unsafeInterleaveIO $ descendants p)-  where -    descendants path =-        do d <- doesDirectoryExist path-           if d then do cs <- getDirectoryContents path-                        let cs' = [path</>c | c <- cs, includeDir c]-                        ds <- recurseDirectories cs'-                        return ds-                else return []-     where includeDir "." = False-           includeDir ".." = False-           includeDir _ = True--data TarEntry = TarEntry { entryHdr :: TarHeader, entrySize :: Integer, entryModTime :: EpochTime, entryCnt :: ByteString }---- | Creates an uncompressed archive-entries2Archive :: [TarEntry] -> ByteString-entries2Archive es = BS.concat $ (map putTarEntry es) ++ [BS.replicate (512*2) 0]---- TODO: It needs to return the handle only because of the hack in createTarGzFile-createTarEntry :: FilePath -- ^ path to find the file-               -> FilePath -- ^ path to use for the TarHeader-               -> IO (TarEntry,Maybe Handle)-createTarEntry path relpath =-    do ftype <- getFileType path-       let tarpath = nativePathToTarPath ftype relpath-       when (null tarpath || length tarpath > 255) $-            die $ "Path too long: " ++ show tarpath-       mode <- getFileMode ftype path-       let hdr = TarHeader {-                   tarFileName = tarpath,-                   tarFileMode = mode,-                   tarFileType = ftype,-                   tarLinkTarget = ""-                 }-       (sz,cnt,mh) <- case ftype of-                TarNormalFile -> do h <- openBinaryFile path ReadMode-                                    sz <- hFileSize h-                                    cnt <- BS.hGetContents h-                                    return (sz,cnt,Just h)-                _             -> return (0,BS.empty,Nothing)-       time <- getModTime path-       return $ (TarEntry hdr sz time cnt,mh)--getFileType :: FilePath -> IO TarFileType-getFileType path = do b <- doesFileExist path-                      if b then return TarNormalFile-                        else do b' <- doesDirectoryExist path-                                if b' then return TarDirectory-                                   else fail $ "tar: Not directory nor regular file: " ++ path---- We can't be precise because of portability, so we default to rw-r--r-- for normal files--- and rwxr-xr-x for directories and executables.-getFileMode :: TarFileType -> FilePath -> IO FileMode-getFileMode ftype path = do-  perms <- getPermissions path-  let x = if executable perms || ftype == TarDirectory then 0o000111 else 0-  return $ 0o000644 .|. x--type EpochTime = Int-          -getModTime :: FilePath -> IO EpochTime-getModTime path = -    do (TOD s _) <- getModificationTime path-       return (fromIntegral s)--putTarEntry :: TarEntry -> ByteString-putTarEntry TarEntry{entryHdr=hdr,entrySize=size,entryModTime=time,entryCnt=cnt} = -  BS.concat-    [putTarHeader hdr size time-    ,cnt-    ,BS.replicate ((- fromIntegral size) `mod` 512) 0-    ]---putTarHeader :: TarHeader -> Integer -> EpochTime -> BS.ByteString-putTarHeader hdr filesize modTime = -    let block = concat $ (putHeaderNoChkSum hdr filesize modTime)-        chkSum = foldl' (\x y -> x + ord y) 0 block-    in BS.Char8.pack $ take 148 block ++-       putOct 8 chkSum ++-       drop 156 block--putHeaderNoChkSum :: TarHeader -> Integer -> EpochTime -> [String]-putHeaderNoChkSum hdr filesize modTime =-    let (filePrefix, fileSuffix) = splitLongPath (tarFileName hdr) in-    [   putString  100 $ fileSuffix-     ,  putOct       8 $ tarFileMode hdr-     ,  putOct       8 $ zero --tarOwnerID hdr-     ,  putOct       8 $ zero --tarGroupID hdr-     ,  putOct      12 $ filesize --tarFileSize hdr-     ,  putOct      12 $ modTime --epochTimeToSecs $ tarModTime hdr-     ,  fill         8 $ ' ' -- dummy checksum-     ,  putTarFileType $ tarFileType hdr-     ,  putString  100 $ tarLinkTarget hdr -- FIXME: take suffix split at / if too long-     ,  putString    6 $ "ustar"-     ,  putString    2 $ "00" -- no nul byte-     ,  putString   32 $ "" --tarOwnerName hdr-     ,  putString   32 $ "" --tarGroupName hdr-     ,  putOct       8 $ zero --tarDeviceMajor hdr-     ,  putOct       8 $ zero --tarDeviceMinor hdr-     ,  putString  155 $ filePrefix-     ,  fill        12 $ '\NUL'-    ]-    where zero :: Int-          zero = 0--putTarFileType :: TarFileType -> String-putTarFileType t = -    putChar8 $ case t of-                 TarNormalFile      -> '0'-                 TarHardLink        -> '1'-                 TarSymbolicLink    -> '2'-                 TarDirectory       -> '5'-                 TarOther c         -> c---- | Convert a native path to a unix\/posix style path--- and for directories add a trailing @\/@.----nativePathToTarPath :: TarFileType -> FilePath -> FilePath-nativePathToTarPath ftype = addTrailingSep ftype-                          . FilePath.Posix.joinPath-                          . FilePath.splitDirectories-  where -    addTrailingSep TarDirectory path = path ++ [FilePath.Posix.pathSeparator]-    addTrailingSep _            path = path---- | Takes a sanitized path, i.e. converted to Posix form-splitLongPath :: FilePath -> (String,String)-splitLongPath path =-    let (x,y) = splitAt (length path - 101) path -              -- 101 since we will always move a separator to the prefix  -     in if null x -         then if null y then err "Empty path." else ("", y)-         else case break (==FilePath.Posix.pathSeparator) y of-              --TODO: convert this to use FilePath.Posix.splitPath-                (_,"")    -> err "Can't split path." -                (_,_:"")  -> err "Can't split path." -                (y1,s:y2) | length p > 155 || length y2 > 100 -> err "Can't split path."-                          | otherwise -> (p,y2)-                      where p = x ++ y1 ++ [s]-  where err e = error $ show path ++ ": " ++ e---- * TAR format primitive output--putString :: Int -> String -> String-putString n s = take n s ++-                   fill (n - length s) '\NUL'--putOct :: (Integral a) => Int -> a -> String-putOct n x = let o = take (n-1) $ showOct x "" in-                fill (n - length o - 1) '0' ++-                o ++-                putChar8 '\NUL'--putChar8 :: Char -> String-putChar8 c = [c]--fill :: Int -> Char -> String-fill n c = replicate n c
− Hackage/Types.hs 
@@ -1,107 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Hackage.Types--- Copyright   :  (c) David Himmelstrup 2005--- License     :  BSD-like------ Maintainer  :  lemmih@gmail.com--- Stability   :  provisional--- Portability :  portable------ All data types for the entire cabal-install system gathered here to avoid some .hs-boot files.-------------------------------------------------------------------------------module Hackage.Types where--import Distribution.Package-         ( PackageIdentifier(..), Package(..), PackageFixedDeps(..)-         , Dependency )-import Distribution.PackageDescription-         ( GenericPackageDescription, FlagAssignment )--import Network.URI (URI)-import Control.Exception-         ( Exception )--newtype Username = Username { unUsername :: String }-newtype Password = Password { unPassword :: String }---- | A 'ConfiguredPackage' is a not-yet-installed package along with the--- total configuration information. The configuration information is total in--- the sense that it provides all the configuration information and so the--- final configure process will be independent of the environment.----data ConfiguredPackage = ConfiguredPackage-       AvailablePackage    -- package info, including repo-       FlagAssignment      -- complete flag assignment for the package-       [PackageIdentifier] -- set of exact dependencies. These must be-                           -- consistent with the 'buildDepends' in the-                           -- 'PackageDescrption' that you'd get by applying-                           -- the flag assignment.-  deriving Show--instance Package ConfiguredPackage where-  packageId (ConfiguredPackage pkg _ _) = packageId pkg--instance PackageFixedDeps ConfiguredPackage where-  depends (ConfiguredPackage _ _ deps) = deps----- | We re-use @GenericPackageDescription@ and use the @package-url@--- field to store the tarball URI.-data AvailablePackage = AvailablePackage {-    packageInfoId      :: PackageIdentifier,-    packageDescription :: GenericPackageDescription,-    packageSource      :: AvailablePackageSource-  }-  deriving Show--instance Package AvailablePackage where packageId = packageInfoId--data AvailablePackageSource =--    -- | The unpacked package in the current dir-    LocalUnpackedPackage-    -    -- | A package available as a tarball from a remote repository, with a-    -- locally cached copy. ie a package available from hackage-  | RepoTarballPackage Repo----  | ScmPackage-  deriving Show----TODO:---  * generalise local package to any local unpacked package, not just in the---      current dir, ie add a FilePath param---  * add support for darcs and other SCM style remote repos with a local cache--data RemoteRepo = RemoteRepo {-    remoteRepoName :: String,-    remoteRepoURI  :: URI-  }-  deriving (Show,Eq)--data Repo = Repo {-    repoRemote   :: RemoteRepo,-    repoCacheDir :: FilePath-  }-  deriving (Show,Eq)--repoName :: Repo -> String-repoName = remoteRepoName . repoRemote--repoURI :: Repo -> URI-repoURI = remoteRepoURI . repoRemote--data UnresolvedDependency-    = UnresolvedDependency-    { dependency :: Dependency-    , depFlags   :: FlagAssignment-    }-  deriving (Show)--data BuildResult = DependentFailed PackageIdentifier-                 | UnpackFailed    Exception-                 | ConfigureFailed Exception-                 | BuildFailed     Exception-                 | InstallFailed   Exception-                 | BuildOk
− Hackage/Update.hs 
@@ -1,37 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Hackage.Update--- Copyright   :  (c) David Himmelstrup 2005--- License     :  BSD-like------ Maintainer  :  lemmih@gmail.com--- Stability   :  provisional--- Portability :  portable-------------------------------------------------------------------------------------module Hackage.Update-    ( update-    ) where--import Hackage.Types-import Hackage.Fetch--import Distribution.Simple.Utils (notice)-import Distribution.Verbosity (Verbosity)--import qualified Data.ByteString.Lazy as BS-import qualified Codec.Compression.GZip as GZip (decompress)-import System.FilePath (dropExtension)---- | 'update' downloads the package list from all known servers-update :: Verbosity -> [Repo] -> IO ()-update verbosity = mapM_ (updateRepo verbosity)--updateRepo :: Verbosity -> Repo -> IO ()-updateRepo verbosity repo = do-  notice verbosity $ "Downloading package list from server '"-                  ++ show (repoURI repo) ++ "'"-  indexPath <- downloadIndex verbosity repo-  BS.writeFile (dropExtension indexPath) . GZip.decompress-                                       =<< BS.readFile indexPath
− Hackage/Upload.hs 
@@ -1,137 +0,0 @@--- This is a quick hack for uploading packages to Hackage.--- See http://hackage.haskell.org/trac/hackage/wiki/CabalUpload--module Hackage.Upload (check, upload) where--import Hackage.Types (Username(..), Password(..))-import Hackage.HttpUtils (proxy)--import Distribution.Simple.Utils (debug, notice, warn)-import Distribution.Verbosity (Verbosity)--import Network.Browser (BrowserAction, browse, request, -                        Authority(..), addAuthority,-                        setOutHandler, setErrHandler, setProxy)-import Network.HTTP (Header(..), HeaderName(..), Request(..),-                     RequestMethod(..), Response(..))-import Network.URI (URI, parseURI)--import Data.Char        (intToDigit)-import Numeric          (showHex)-import System.IO        (hFlush, stdin, stdout, hGetEcho, hSetEcho-                        ,openBinaryFile, IOMode(ReadMode), hGetContents)-import Control.Exception (bracket)-import System.Random    (randomRIO)------FIXME: how do we find this path for an arbitrary hackage server?--- is it always at some fixed location relative to the server root?-uploadURI :: URI-Just uploadURI = parseURI "http://hackage.haskell.org/cgi-bin/hackage-scripts/protected/upload-pkg"--checkURI :: URI-Just checkURI = parseURI "http://hackage.haskell.org/cgi-bin/hackage-scripts/check-pkg"---upload :: Verbosity -> Maybe Username -> Maybe Password -> [FilePath] -> IO ()-upload verbosity mUsername mPassword paths = do--          Username username <- maybe promptUsername return mUsername-          Password password <- maybe promptPassword return mPassword-          let auth = addAuthority AuthBasic {-                       auRealm    = "Hackage",-                       auUsername = username,-                       auPassword = password,-                       auSite     = uploadURI-                     }--          flip mapM_ paths $ \path -> do-            notice verbosity $ "Uploading " ++ path ++ "... "-            handlePackage verbosity uploadURI auth path--  where-    promptUsername :: IO Username-    promptUsername = do-      putStr "Hackage username: "-      hFlush stdout-      fmap Username getLine--    promptPassword :: IO Password-    promptPassword = do-      putStr "Hackage password: "-      hFlush stdout-      -- save/restore the terminal echoing status-      bracket (hGetEcho stdin) (hSetEcho stdin) $ \_ -> do-        hSetEcho stdin False  -- no echoing for entering the password-        fmap Password getLine--check :: Verbosity -> [FilePath] -> IO ()-check verbosity paths = do-          flip mapM_ paths $ \path -> do-            notice verbosity $ "Checking " ++ path ++ "... "-            handlePackage verbosity checkURI (return ()) path--handlePackage :: Verbosity -> URI -> BrowserAction () -> FilePath -> IO ()-handlePackage verbosity uri auth path =-  do req <- mkRequest uri path-     p   <- proxy verbosity-     debug verbosity $ "\n" ++ show req-     (_,resp) <- browse $ do-                   setProxy p-                   setErrHandler (warn verbosity . ("http error: "++))-                   setOutHandler (debug verbosity)-                   auth-                   request req-     debug verbosity $ show resp-     case rspCode resp of-       (2,0,0) -> do notice verbosity "OK"-       (x,y,z) -> do notice verbosity $ "ERROR: " ++ path ++ ": " -                                     ++ map intToDigit [x,y,z] ++ " "-                                     ++ rspReason resp-                     debug verbosity $ rspBody resp--mkRequest :: URI -> FilePath -> IO Request-mkRequest uri path = -    do pkg <- readBinaryFile path-       boundary <- genBoundary-       let body = printMultiPart boundary (mkFormData path pkg)-       return $ Request {-                         rqURI = uri,-                         rqMethod = POST,-                         rqHeaders = [Header HdrContentType ("multipart/form-data; boundary="++boundary),-                                      Header HdrContentLength (show (length body)),-                                      Header HdrAccept ("text/plain")],-                         rqBody = body-                        }--readBinaryFile :: FilePath -> IO String-readBinaryFile path = openBinaryFile path ReadMode >>= hGetContents--genBoundary :: IO String-genBoundary = do i <- randomRIO (0x10000000000000,0xFFFFFFFFFFFFFF) :: IO Integer-                 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]--hdrContentDisposition :: HeaderName-hdrContentDisposition = HdrCustom "Content-disposition"---- * Multipart, partly stolen from the cgi package.--data BodyPart = BodyPart [Header] String--printMultiPart :: String -> [BodyPart] -> String-printMultiPart boundary xs = -    concatMap (printBodyPart boundary) xs ++ crlf ++ "--" ++ boundary ++ "--" ++ crlf--printBodyPart :: String -> BodyPart -> String-printBodyPart boundary (BodyPart hs c) = crlf ++ "--" ++ boundary ++ crlf ++ concatMap show hs ++ crlf ++ c--crlf :: String-crlf = "\r\n"
− Hackage/Utils.hs 
@@ -1,55 +0,0 @@-module Hackage.Utils where--import Distribution.Package-         ( Dependency(..) )-import Distribution.Text-         ( display )-import Distribution.Simple.Utils (intercalate)--import Data.List-         ( sortBy, groupBy )-import Control.Monad (guard)-import Control.Exception (Exception, catchJust, ioErrors)-import System.IO.Error (isDoesNotExistError)--readFileIfExists :: FilePath -> IO (Maybe String)-readFileIfExists path =-    catchJust fileNotFoundExceptions -                  (fmap Just (readFile path))-                  (\_ -> return Nothing)--fileNotFoundExceptions :: Exception -> Maybe IOError-fileNotFoundExceptions e = -    ioErrors e >>= \ioe -> guard (isDoesNotExistError ioe) >> return ioe--showDependencies :: [Dependency] -> String-showDependencies = intercalate ", " . map display---- | Generic merging utility. For sorted input lists this is a full outer join.------ * The result list never contains @(Nothing, Nothing)@.----mergeBy :: (a -> b -> Ordering) -> [a] -> [b] -> [MergeResult a b]-mergeBy cmp = merge-  where-    merge []     ys     = [ OnlyInRight y | y <- ys]-    merge xs     []     = [ OnlyInLeft  x | x <- xs]-    merge (x:xs) (y:ys) =-      case x `cmp` y of-        GT -> OnlyInRight   y : merge (x:xs) ys-        EQ -> InBoth      x y : merge xs     ys-        LT -> OnlyInLeft  x   : merge xs  (y:ys)--data MergeResult a b = OnlyInLeft a | InBoth a b | OnlyInRight b--duplicates :: Ord a => [a] -> [[a]]-duplicates = duplicatesBy compare--duplicatesBy :: (a -> a -> Ordering) -> [a] -> [[a]]-duplicatesBy cmp = filter moreThanOne . groupBy eq . sortBy cmp-  where-    eq a b = case cmp a b of-               EQ -> True-               _  -> False-    moreThanOne (_:_:_) = True-    moreThanOne _       = False
Main.hs view
@@ -13,34 +13,51 @@  module Main where -import Hackage.Setup-import Hackage.Types+import Distribution.Client.Setup+         ( GlobalFlags(..), globalCommand, globalRepos+         , ConfigFlags(..), configureCommand+         , InstallFlags(..), installCommand, upgradeCommand+         , fetchCommand, checkCommand+         , updateCommand+         , ListFlags(..), listCommand+         , UploadFlags(..), uploadCommand+         , reportCommand+         , parsePackageArgs, configPackageDB' )+import Distribution.Simple.Setup+         ( BuildFlags(..), buildCommand+         , HaddockFlags(..), haddockCommand+         , HscolourFlags(..), hscolourCommand+         , CopyFlags(..), copyCommand+         , RegisterFlags(..), registerCommand+         , CleanFlags(..), cleanCommand+         , SDistFlags(..), sdistCommand+         , TestFlags(..), testCommand+         , Flag(..), fromFlag, fromFlagOrDefault, flagToMaybe )++import Distribution.Client.Types          ( UnresolvedDependency(UnresolvedDependency) )-import Distribution.Simple.Setup (Flag(..), fromFlag, fromFlagOrDefault,-                                  flagToMaybe,SDistFlags,sdistCommand)-import qualified Distribution.Simple.Setup as Cabal+import Distribution.Client.SetupWrapper+         ( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions )+import Distribution.Client.Config+         ( SavedConfig(..), loadConfig )+import Distribution.Client.List             (list)+import Distribution.Client.Install          (install, upgrade)+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 qualified Distribution.Client.Win32SelfUpgrade as Win32SelfUpgrade+ import Distribution.Simple.Program (defaultProgramConfiguration) import Distribution.Simple.Command import Distribution.Simple.Configure (configCompilerAux) import Distribution.Simple.Utils (cabalVersion, die, intercalate) import Distribution.Text          ( display )--import Hackage.SetupWrapper-         ( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions )-import Hackage.Config           (SavedConfig(..), savedConfigToConfigFlags,-                                 defaultConfigFile, loadConfig, configRepos,-                                 configPackageDB)-import Hackage.List             (list)-import Hackage.Install          (install, upgrade)-import Hackage.Update           (update)-import Hackage.Fetch            (fetch)-import Hackage.Check as Check   (check)---import Hackage.Clean            (clean)-import Hackage.Upload as Upload (upload, check)-import Hackage.SrcDist(sdist)--import Distribution.Verbosity   (Verbosity, normal)+import Distribution.Verbosity as Verbosity+       ( Verbosity, normal, intToVerbosity ) import qualified Paths_cabal_install (version)  import System.Environment       (getArgs, getProgName)@@ -48,6 +65,7 @@ import System.FilePath          (splitExtension, takeExtension) import System.Directory         (doesFileExist) import Data.List                (intersperse)+import Data.Maybe               (fromMaybe) import Data.Monoid              (Monoid(..)) import Control.Monad            (unless) @@ -57,19 +75,20 @@ main = getArgs >>= mainWorker  mainWorker :: [String] -> IO ()-mainWorker args = +mainWorker ("win32selfupgrade":args) = win32SelfUpgradeAction args+mainWorker args =   case commandsRun globalCommand commands args of     CommandHelp   help                 -> printHelp help     CommandList   opts                 -> printOptionsList opts     CommandErrors errs                 -> printErrors errs-    CommandReadyToGo (flags, commandParse)  ->+    CommandReadyToGo (globalflags, commandParse)  ->       case commandParse of-        _ | fromFlag (globalVersion flags)        -> printVersion-          | fromFlag (globalNumericVersion flags) -> printNumericVersion+        _ | fromFlag (globalVersion globalflags)        -> printVersion+          | fromFlag (globalNumericVersion globalflags) -> printNumericVersion         CommandHelp     help           -> printHelp help         CommandList     opts           -> printOptionsList opts         CommandErrors   errs           -> printErrors errs-        CommandReadyToGo action        -> action+        CommandReadyToGo action        -> action globalflags    where     printHelp help = getProgName >>= putStr . help@@ -94,29 +113,31 @@       ,uploadCommand          `commandAddAction` uploadAction       ,checkCommand           `commandAddAction` checkAction       ,sdistCommand           `commandAddAction` sdistAction-      ,wrapperAction (Cabal.buildCommand defaultProgramConfiguration)-                     Cabal.buildVerbosity    Cabal.buildDistPref-      ,wrapperAction Cabal.copyCommand-                     Cabal.copyVerbosity     Cabal.copyDistPref-      ,wrapperAction Cabal.haddockCommand-                     Cabal.haddockVerbosity  Cabal.haddockDistPref-      ,wrapperAction Cabal.cleanCommand-                     Cabal.cleanVerbosity    Cabal.cleanDistPref-      ,wrapperAction Cabal.hscolourCommand-                     Cabal.hscolourVerbosity Cabal.hscolourDistPref-      ,wrapperAction Cabal.registerCommand-                     Cabal.regVerbosity      Cabal.regDistPref-      ,wrapperAction Cabal.testCommand-                     Cabal.testVerbosity     Cabal.testDistPref+      ,reportCommand          `commandAddAction` reportAction+      ,wrapperAction (buildCommand defaultProgramConfiguration)+                     buildVerbosity    buildDistPref+      ,wrapperAction copyCommand+                     copyVerbosity     copyDistPref+      ,wrapperAction haddockCommand+                     haddockVerbosity  haddockDistPref+      ,wrapperAction cleanCommand+                     cleanVerbosity    cleanDistPref+      ,wrapperAction hscolourCommand+                     hscolourVerbosity hscolourDistPref+      ,wrapperAction registerCommand+                     regVerbosity      regDistPref+      ,wrapperAction testCommand+                     testVerbosity     testDistPref       ]  wrapperAction :: Monoid flags               => CommandUI flags               -> (flags -> Flag Verbosity)               -> (flags -> Flag String)-              -> Command (IO ())+              -> Command (GlobalFlags -> IO ()) wrapperAction command verbosityFlag distPrefFlag =-  commandAddAction command $ \flags extraArgs -> do+  commandAddAction command+    { commandDefaultFlags = mempty } $ \flags extraArgs _globalFlags -> do     let verbosity = fromFlagOrDefault normal (verbosityFlag flags)         setupScriptOptions = defaultSetupScriptOptions {           useDistPref = fromFlagOrDefault@@ -126,113 +147,108 @@     setupWrapper verbosity setupScriptOptions Nothing                  command (const flags) extraArgs -configureAction :: Cabal.ConfigFlags -> [String] -> IO ()-configureAction flags extraArgs = do-  configFile <- defaultConfigFile --FIXME-  let verbosity = fromFlagOrDefault normal (Cabal.configVerbosity flags)-  config <- loadConfig verbosity configFile-  let flags' = savedConfigToConfigFlags (Cabal.configUserInstall flags) config-               `mappend` flags+configureAction :: ConfigFlags -> [String] -> GlobalFlags -> IO ()+configureAction flags extraArgs globalFlags = do+  let verbosity = fromFlagOrDefault normal (configVerbosity flags)+  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)-                             (Cabal.configDistPref flags)+                             (configDistPref flags)       }   setupWrapper verbosity setupScriptOptions Nothing     configureCommand (const flags') extraArgs -installAction :: (Cabal.ConfigFlags, InstallFlags) -> [String] -> IO ()-installAction (cflags,iflags) _-  | Cabal.fromFlag (installOnly iflags)-  = let verbosity = fromFlagOrDefault normal (Cabal.configVerbosity cflags)+installAction :: (ConfigFlags, InstallFlags) -> [String] -> GlobalFlags -> IO ()+installAction (cflags,iflags) _ _globalFlags+  | fromFlagOrDefault False (installOnly iflags)+  = let verbosity = fromFlagOrDefault normal (configVerbosity cflags)     in setupWrapper verbosity defaultSetupScriptOptions Nothing-         Cabal.installCommand mempty []+         installCommand mempty [] -installAction (cflags,iflags) extraArgs = do+installAction (cflags,iflags) extraArgs globalFlags = do   pkgs <- either die return (parsePackageArgs extraArgs)-  configFile <- defaultConfigFile --FIXME-  let verbosity = fromFlagOrDefault normal (Cabal.configVerbosity cflags)-  config <- loadConfig verbosity configFile-  let cflags' = savedConfigToConfigFlags (Cabal.configUserInstall cflags) config-               `mappend` cflags+  let verbosity = fromFlagOrDefault normal (configVerbosity cflags)+  config <- loadConfig verbosity (globalConfigFile globalFlags)+                                 (configUserInstall cflags)+  let cflags' = savedConfigureFlags config `mappend` cflags+      iflags' = savedInstallFlags   config `mappend` iflags   (comp, conf) <- configCompilerAux cflags'   install verbosity-          (configPackageDB cflags') (configRepos config)-          comp conf cflags' iflags-          [ UnresolvedDependency pkg (Cabal.configConfigurationsFlags cflags')+          (configPackageDB' cflags') (globalRepos (savedGlobalFlags config))+          comp conf cflags' iflags'+          [ UnresolvedDependency pkg (configConfigurationsFlags cflags')           | pkg <- pkgs ] -listAction :: ListFlags -> [String] -> IO ()-listAction listFlags extraArgs = do-  configFile <- defaultConfigFile --FIXME+listAction :: ListFlags -> [String] -> GlobalFlags -> IO ()+listAction listFlags extraArgs globalFlags = do   let verbosity = fromFlag (listVerbosity listFlags)-  config <- loadConfig verbosity configFile-  let flags = savedConfigToConfigFlags NoFlag config+  config <- loadConfig verbosity (globalConfigFile globalFlags) mempty+  let flags = savedConfigureFlags config   (comp, conf) <- configCompilerAux flags   list verbosity-       (configPackageDB flags)-       (configRepos config)+       (configPackageDB' flags)+       (globalRepos (savedGlobalFlags config))        comp        conf        listFlags        extraArgs -updateAction :: Flag Verbosity -> [String] -> IO ()-updateAction verbosityFlag extraArgs = do+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-  configFile <- defaultConfigFile --FIXME   let verbosity = fromFlag verbosityFlag-  config <- loadConfig verbosity configFile-  update verbosity (configRepos config)+  config <- loadConfig verbosity (globalConfigFile globalFlags) mempty+  update verbosity (globalRepos (savedGlobalFlags config)) -upgradeAction :: (Cabal.ConfigFlags, InstallFlags) -> [String] -> IO ()-upgradeAction (cflags,iflags) extraArgs = do+upgradeAction :: (ConfigFlags, InstallFlags) -> [String] -> GlobalFlags -> IO ()+upgradeAction (cflags,iflags) extraArgs globalFlags = do   pkgs <- either die return (parsePackageArgs extraArgs)-  configFile <- defaultConfigFile --FIXME-  let verbosity = fromFlagOrDefault normal (Cabal.configVerbosity cflags)-  config <- loadConfig verbosity configFile-  let cflags' = savedConfigToConfigFlags (Cabal.configUserInstall cflags) config-               `mappend` cflags+  let verbosity = fromFlagOrDefault normal (configVerbosity cflags)+  config <- loadConfig verbosity (globalConfigFile globalFlags)+                                 (configUserInstall cflags)+  let cflags' = savedConfigureFlags config `mappend` cflags+      iflags' = savedInstallFlags   config `mappend` iflags   (comp, conf) <- configCompilerAux cflags'   upgrade verbosity-          (configPackageDB cflags') (configRepos config)-          comp conf cflags' iflags-          [ UnresolvedDependency pkg (Cabal.configConfigurationsFlags cflags')+          (configPackageDB' cflags') (globalRepos (savedGlobalFlags config))+          comp conf cflags' iflags'+          [ UnresolvedDependency pkg (configConfigurationsFlags cflags')           | pkg <- pkgs ] -fetchAction :: Flag Verbosity -> [String] -> IO ()-fetchAction verbosityFlag extraArgs = do+fetchAction :: Flag Verbosity -> [String] -> GlobalFlags -> IO ()+fetchAction verbosityFlag extraArgs globalFlags = do   pkgs <- either die return (parsePackageArgs extraArgs)-  configFile <- defaultConfigFile --FIXME   let verbosity = fromFlag verbosityFlag-  config <- loadConfig verbosity configFile-  let flags = savedConfigToConfigFlags NoFlag config+  config <- loadConfig verbosity (globalConfigFile globalFlags) mempty+  let flags = savedConfigureFlags config   (comp, conf) <- configCompilerAux flags   fetch verbosity-        (configPackageDB flags) (configRepos config)+        (configPackageDB' flags) (globalRepos (savedGlobalFlags config))         comp conf         [ UnresolvedDependency pkg [] --TODO: flags?         | pkg <- pkgs ] -uploadAction :: UploadFlags -> [String] -> IO ()-uploadAction flags extraArgs = do-  configFile <- defaultConfigFile --FIXME-  let verbosity = fromFlag (uploadVerbosity flags)-  config <- loadConfig verbosity configFile+uploadAction :: UploadFlags -> [String] -> GlobalFlags -> IO ()+uploadAction uploadFlags extraArgs globalFlags = do+  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-  if fromFlag (uploadCheck flags)+  if fromFlag (uploadCheck uploadFlags')     then Upload.check  verbosity tarfiles-    else upload verbosity -                (flagToMaybe $ configUploadUsername config-                     `mappend` uploadUsername flags)-                (flagToMaybe $ configUploadPassword config-                     `mappend` uploadPassword flags)+    else upload verbosity+                (globalRepos (savedGlobalFlags config))+                (flagToMaybe $ uploadUsername uploadFlags')+                (flagToMaybe $ uploadPassword uploadFlags')                 tarfiles   where     checkTarFiles tarfiles@@ -251,16 +267,36 @@               (file', ".gz") -> takeExtension file' == ".tar"               _              -> False -checkAction :: Flag Verbosity -> [String] -> IO ()-checkAction verbosityFlag extraArgs = do+checkAction :: Flag Verbosity -> [String] -> GlobalFlags -> IO ()+checkAction verbosityFlag extraArgs _globalFlags = do   unless (null extraArgs) $ do     die $ "'check' doesn't take any extra arguments: " ++ unwords extraArgs   allOk <- Check.check (fromFlag verbosityFlag)   unless allOk exitFailure  -sdistAction :: SDistFlags -> [String] -> IO ()-sdistAction sflags extraArgs = do+sdistAction :: SDistFlags -> [String] -> GlobalFlags -> IO ()+sdistAction sflags extraArgs _globalFlags = do   unless (null extraArgs) $ do     die $ "'sdist' doesn't take any extra arguments: " ++ unwords extraArgs   sdist sflags++reportAction :: Flag Verbosity -> [String] -> GlobalFlags -> IO ()+reportAction verbosityFlag extraArgs globalFlags = do+  unless (null extraArgs) $ do+    die $ "'report' doesn't take any extra arguments: " ++ unwords extraArgs++  let verbosity = fromFlag verbosityFlag+  config <- loadConfig verbosity (globalConfigFile globalFlags) mempty++  Upload.report verbosity (globalRepos (savedGlobalFlags config))++win32SelfUpgradeAction :: [String] -> IO ()+win32SelfUpgradeAction (pid:path:rest) =+  Win32SelfUpgrade.deleteOldExeFile verbosity (read pid) path+  where+    verbosity = case rest of+      (['-','-','v','e','r','b','o','s','e','=',n]:_) | n `elem` ['0'..'9']+         -> fromMaybe Verbosity.normal (Verbosity.intToVerbosity (read [n]))+      _  ->           Verbosity.normal+win32SelfUpgradeAction _ = return ()
+ bootstrap.sh view
@@ -0,0 +1,40 @@+#!/bin/sh++# A script to bootstrap cabal-install.++# It works by downloading and installing the Cabal, zlib and+# HTTP packages. It then installs cabal-install itself.+# It expects to be run inside the cabal-install directory.++CABAL_VER="1.4.0.2"+HTTP_VER="3001.0.4"+ZLIB_VER="0.4.0.4"++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++wget ${CABAL_URL} ${HTTP_URL} ${ZLIB_URL}++tar -zxf Cabal-${CABAL_VER}.tar.gz+pushd Cabal-${CABAL_VER}+ghc --make Setup+./Setup configure --user && ./Setup build && ./Setup install+popd++tar -zxf HTTP-${HTTP_VER}.tar.gz+pushd HTTP-${HTTP_VER}+runghc Setup configure --user && runghc Setup build && runghc Setup install+popd++tar -zxf zlib-${ZLIB_VER}.tar.gz+pushd zlib-${ZLIB_VER}+runghc Setup configure --user && runghc Setup build && runghc Setup install+popd++runghc Setup configure --user && runghc Setup build && runghc Setup install++echo+echo "If all went well then 'cabal' is in $HOME/.cabal/bin/"+echo "You may want to add this dir to your PATH"
cabal-install.cabal view
@@ -1,7 +1,7 @@ Name:               cabal-install-Version:            0.5.1+Version:            0.5.2 Synopsis:           The command-line interface for Cabal and Hackage.-Description:        +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.@@ -9,19 +9,19 @@ License-File:       LICENSE Author:             Lemmih <lemmih@gmail.com>                     Paolo Martini <paolo@nemail.it>-		    Bjorn Bringert <bjorn@bringert.net>-		    Isaac Potoczny-Jones <ijones@syntaxpolice.org>-		    Duncan Coutts <duncan@haskell.org>+                    Bjorn Bringert <bjorn@bringert.net>+                    Isaac Potoczny-Jones <ijones@syntaxpolice.org>+                    Duncan Coutts <duncan@haskell.org> Maintainer:         cabal-devel@haskell.org Copyright:          2005 Lemmih <lemmih@gmail.com>                     2006 Paolo Martini <paolo@nemail.it>-		    2007 Bjorn Bringert <bjorn@bringert.net>-		    2007 Isaac Potoczny-Jones <ijones@syntaxpolice.org>-		    2008 Duncan Coutts <duncan@haskell.org>+                    2007 Bjorn Bringert <bjorn@bringert.net>+                    2007 Isaac Potoczny-Jones <ijones@syntaxpolice.org>+                    2008 Duncan Coutts <duncan@haskell.org> Stability:          Experimental Category:           Distribution Build-type:         Simple-Extra-Source-Files: README bash-completion/cabal+Extra-Source-Files: README bash-completion/cabal bootstrap.sh Cabal-Version:      >= 1.2  flag old-base@@ -36,33 +36,33 @@     -- although it is expensive, we want to catch problems early:     Ghc-Options:        -Wall -fno-ignore-asserts     Other-Modules:-        Hackage.Check---        Hackage.Clean-        Hackage.Config-        Hackage.Dependency-        Hackage.Dependency.Bogus-        Hackage.Dependency.Naive-        Hackage.Dependency.TopDown-        Hackage.Dependency.TopDown.Constraints-        Hackage.Dependency.TopDown.Types-        Hackage.Dependency.Types-        Hackage.Fetch-        Hackage.HttpUtils-        Hackage.IndexUtils---        Hackage.Info-        Hackage.Install-        Hackage.InstallPlan-        Hackage.List-        Hackage.ParseUtils-        Hackage.Reporting-        Hackage.Setup-        Hackage.SetupWrapper-        Hackage.SrcDist-        Hackage.Tar-        Hackage.Types-        Hackage.Update-        Hackage.Upload-        Hackage.Utils+        Distribution.Client.BuildReports.Anonymous+        Distribution.Client.BuildReports.Storage+        Distribution.Client.BuildReports.Upload+        Distribution.Client.Check+        Distribution.Client.Config+        Distribution.Client.Dependency+        Distribution.Client.Dependency.Bogus+        Distribution.Client.Dependency.TopDown+        Distribution.Client.Dependency.TopDown.Constraints+        Distribution.Client.Dependency.TopDown.Types+        Distribution.Client.Dependency.Types+        Distribution.Client.Fetch+        Distribution.Client.HttpUtils+        Distribution.Client.IndexUtils+        Distribution.Client.Install+        Distribution.Client.InstallPlan+        Distribution.Client.InstallSymlink+        Distribution.Client.List+        Distribution.Client.Setup+        Distribution.Client.SetupWrapper+        Distribution.Client.SrcDist+        Distribution.Client.Tar+        Distribution.Client.Types+        Distribution.Client.Update+        Distribution.Client.Upload+        Distribution.Client.Utils+        Distribution.Client.Win32SelfUpgrade      build-depends: Cabal >= 1.4 && < 1.5,                    filepath >= 1.0,@@ -90,3 +90,6 @@     if os(windows)       build-depends: Win32 >= 2 && < 3       cpp-options: -DWIN32+    else+      build-depends: unix >= 2.2 && < 2.4+    extensions: CPP