cabal-install 0.4.0 → 0.5.0
raw patch · 35 files changed
+5052/−1128 lines, 35 filesdep +Win32dep +arraydep +containersdep ~Cabaldep ~HTTPdep ~basesetup-changed
Dependencies added: Win32, array, containers, old-time, random
Dependency ranges changed: Cabal, HTTP, base, directory, network, pretty, process, zlib
Files
- Hackage/Check.hs +81/−0
- Hackage/Clean.hs +0/−29
- Hackage/Config.hs +170/−150
- Hackage/Dependency.hs +156/−133
- Hackage/Dependency/Bogus.hs +73/−0
- Hackage/Dependency/Naive.hs +180/−0
- Hackage/Dependency/TopDown.hs +598/−0
- Hackage/Dependency/TopDown/Constraints.hs +244/−0
- Hackage/Dependency/TopDown/Types.hs +90/−0
- Hackage/Dependency/Types.hs +90/−0
- Hackage/Fetch.hs +105/−72
- Hackage/HttpUtils.hs +94/−0
- Hackage/Index.hs +0/−64
- Hackage/IndexUtils.hs +119/−0
- Hackage/Info.hs +0/−64
- Hackage/Install.hs +309/−129
- Hackage/InstallPlan.hs +497/−0
- Hackage/List.hs +161/−43
- Hackage/ParseUtils.hs +82/−0
- Hackage/Reporting.hs +318/−0
- Hackage/Setup.hs +335/−169
- Hackage/SetupWrapper.hs +300/−0
- Hackage/SrcDist.hs +80/−0
- Hackage/Tar.hs +257/−34
- Hackage/Types.hs +78/−65
- Hackage/Update.hs +14/−12
- Hackage/Upload.hs +137/−0
- Hackage/Utils.hs +37/−80
- LICENSE +3/−2
- Main.hs +234/−30
- README +24/−33
- Setup.hs +2/−0
- Setup.lhs +0/−3
- bash-completion/cabal +131/−0
- cabal-install.cabal +53/−16
+ Hackage/Check.hs view
@@ -0,0 +1,81 @@+-----------------------------------------------------------------------------+-- |+-- 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/Clean.hs
@@ -1,29 +0,0 @@--------------------------------------------------------------------------------- |--- Module : Hackage.Clean--- Copyright : (c) David Himmelstrup 2005--- License : BSD-like------ Maintainer : lemmih@gmail.com--- Stability : provisional--- Portability : portable------ -------------------------------------------------------------------------------module Hackage.Clean- ( clean- ) where--import Hackage.Types (ConfigFlags(..))-import Hackage.Utils (fileNotFoundExceptions)--import System.Directory (removeDirectoryRecursive)-import Control.Exception (catchJust)---- | 'clean' removes all downloaded packages from the {config-dir}\/packages\/ directory.-clean :: ConfigFlags -> IO ()-clean cfg- = catchJust fileNotFoundExceptions- (removeDirectoryRecursive (configCacheDir cfg))- -- The packages dir may not exist if it's already cleaned:- (const (return ()))
Hackage/Config.hs view
@@ -11,94 +11,92 @@ -- Utilities for handling saved state such as known packages, known servers and downloaded packages. ----------------------------------------------------------------------------- module Hackage.Config- ( repoCacheDir- , packageFile- , packageDir- , listInstalledPackages- , message- , pkgURL+ ( SavedConfig(..)+ , savedConfigToConfigFlags+ , configRepos+ , configPackageDB , defaultConfigFile+ , defaultCacheDir , loadConfig , showConfig- , findCompiler ) where import Prelude hiding (catch)-import Control.Monad (when)-import Data.Char (isAlphaNum, toLower)-import Data.List (intersperse)+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 System.IO (hPutStrLn, stderr)+import System.FilePath ((</>), takeDirectory)+import Network.URI (parseAbsoluteURI, uriToString) import Text.PrettyPrint.HughesPJ (text) -import Distribution.Compat.ReadP (ReadP, char, munch1, readS_to_P)+import Distribution.Compat.ReadP as ReadP+ ( ReadP, char, munch1, pfail ) import Distribution.Compiler (CompilerFlavor(..), defaultCompilerFlavor)-import Distribution.Package (PackageIdentifier(..), showPackageId)-import Distribution.PackageDescription (ParseResult(..))-import Distribution.ParseUtils (FieldDescr(..), simpleField, listField, liftField, field)-import Distribution.Simple.Compiler (Compiler, PackageDB(..))-import Distribution.Simple.Configure (getInstalledPackages)-import qualified Distribution.Simple.Configure as Configure (configCompiler)-import Distribution.Simple.InstallDirs (InstallDirTemplates(..), PathTemplate, toPathTemplate, defaultInstallDirs)-import Distribution.Simple.Program (ProgramConfiguration, defaultProgramConfiguration)-import Distribution.Version (showVersion)+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 Hackage.Types (ConfigFlags (..), PkgInfo (..), Repo(..))-import Hackage.Utils----- | Full path to the local cache directory for a repository.-repoCacheDir :: ConfigFlags -> Repo -> FilePath-repoCacheDir cfg repo = configCacheDir cfg </> repoName repo---- |Generate the full path to the locally cached copy of--- the tarball for a given @PackageIdentifer@.-packageFile :: ConfigFlags -> PkgInfo -> FilePath-packageFile cfg pkg = packageDir cfg pkg- </> showPackageId (pkgInfoId pkg)- <.> "tar.gz"+import Hackage.Types+ ( RemoteRepo(..), Repo(..), Username(..), Password(..) )+import Hackage.ParseUtils+import Hackage.Utils (readFileIfExists)+import Distribution.Simple.Utils (notice, warn) --- |Generate the full path to the directory where the local cached copy of--- the tarball for a given @PackageIdentifer@ is stored.-packageDir :: ConfigFlags -> PkgInfo -> FilePath-packageDir cfg pkg = repoCacheDir cfg (pkgRepo pkg)- </> pkgName p- </> showVersion (pkgVersion p)- where p = pkgInfoId pkg+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 -listInstalledPackages :: ConfigFlags -> Compiler -> ProgramConfiguration -> IO [PackageIdentifier]-listInstalledPackages cfg comp conf =- do Just ipkgs <- getInstalledPackages- (configVerbose cfg) comp- (if configUserInstall cfg then UserPackageDB- else GlobalPackageDB)- conf- return ipkgs+--+-- * Configuration saved in the config file+-- -message :: ConfigFlags -> Verbosity -> String -> IO ()-message cfg v s = when (configVerbose cfg >= v) (putStrLn s)+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+ } --- | Generate the URL of the tarball for a given package.-pkgURL :: PkgInfo -> String-pkgURL pkg = joinWith "/" [repoURL (pkgRepo pkg), pkgName p, showVersion (pkgVersion p), - showPackageId p ++ ".tar.gz"] - where joinWith tok = concat . intersperse tok- p = pkgInfoId pkg+configUserInstall :: SavedConfig -> Flag Bool+configUserInstall = ConfigFlags.configUserInstall . configFlags ------ * Compiler and programs---+configRepos :: SavedConfig -> [Repo]+configRepos config =+ [ let cacheDir = fromFlag (configCacheDir config)+ </> remoteRepoName remote+ in Repo remote cacheDir+ | remote <- configRemoteRepos config ] -findCompiler :: ConfigFlags -> IO (Compiler, ProgramConfiguration)-findCompiler cfg = Configure.configCompiler - (Just (configCompiler cfg)) - (configCompilerPath cfg)- (configHcPkgPath cfg)- defaultProgramConfiguration - (configVerbose cfg)+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@@ -118,138 +116,160 @@ defaultCompiler :: CompilerFlavor defaultCompiler = fromMaybe GHC defaultCompilerFlavor -defaultUserInstallDirs :: CompilerFlavor -> IO InstallDirTemplates-defaultUserInstallDirs compiler =- do installDirs <- defaultInstallDirs compiler True- userPrefix <- defaultCabalDir- return $ installDirs { prefixDirTemplate = toPathTemplate userPrefix }+defaultUserInstallDirs :: IO (InstallDirs (Flag PathTemplate))+defaultUserInstallDirs =+ do userPrefix <- defaultCabalDir+ return $ defaultGlobalInstallDirs {+ prefix = toFlag (toPathTemplate userPrefix)+ } -defaultGlobalInstallDirs :: CompilerFlavor -> IO InstallDirTemplates-defaultGlobalInstallDirs compiler = defaultInstallDirs compiler True+defaultGlobalInstallDirs :: InstallDirs (Flag PathTemplate)+defaultGlobalInstallDirs = mempty -defaultConfigFlags :: IO ConfigFlags-defaultConfigFlags = - do userInstallDirs <- defaultUserInstallDirs defaultCompiler- globalInstallDirs <- defaultGlobalInstallDirs defaultCompiler- cacheDir <- defaultCacheDir- return $ ConfigFlags - { configCompiler = defaultCompiler- , configCompilerPath = Nothing- , configHcPkgPath = Nothing- , configUserInstallDirs = userInstallDirs- , configGlobalInstallDirs = globalInstallDirs- , configCacheDir = cacheDir- , configRepos = [Repo "hackage.haskell.org" "http://hackage.haskell.org/packages/archive"]- , configVerbose = normal- , configUserInstall = True- }+defaultSavedConfig :: IO SavedConfig+defaultSavedConfig =+ do userInstallDirs <- defaultUserInstallDirs+ cacheDir <- defaultCacheDir+ return SavedConfig+ { configFlags = mempty {+ ConfigFlags.configHcFlavor = toFlag defaultCompiler+ , ConfigFlags.configVerbosity = toFlag normal+ , ConfigFlags.configUserInstall = toFlag True+ , 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 :: FilePath -> IO ConfigFlags-loadConfig configFile = - do defaultConf <- defaultConfigFlags+loadConfig :: Verbosity -> FilePath -> IO SavedConfig+loadConfig verbosity configFile = + do defaultConf <- defaultSavedConfig minp <- readFileIfExists configFile case minp of- Nothing -> do hPutStrLn stderr $ "Config file " ++ configFile ++ " not found."- hPutStrLn stderr $ "Writing default configuration to " ++ configFile ++ "."+ 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+ Just inp -> case parseBasicStanza configFieldDescrs defaultConf' inp of ParseOk ws conf -> - do mapM_ (hPutStrLn stderr . ("Config file warning: " ++)) ws+ do when (not $ null ws) $ warn verbosity $+ unlines (map (showPWarning configFile) ws) return conf ParseFailed err -> - do hPutStrLn stderr $ "Error parsing config file " + do warn verbosity $ "Error parsing config file " ++ configFile ++ ": " ++ showPError err- hPutStrLn stderr $ "Using default configuration."+ warn verbosity $ "Using default configuration." return defaultConf+ where defaultConf' = defaultConf { configRemoteRepos = [] } -writeDefaultConfigFile :: FilePath -> ConfigFlags -> IO ()+writeDefaultConfigFile :: FilePath -> SavedConfig -> IO () writeDefaultConfigFile file cfg = do createDirectoryIfMissing True (takeDirectory file)- writeFile file $ showFields configWriteFieldDescrs cfg+ writeFile file $ showFields configWriteFieldDescrs cfg ++ "\n" -showConfig :: ConfigFlags -> String+showConfig :: SavedConfig -> String showConfig = showFields configFieldDescrs -- | All config file fields.-configFieldDescrs :: [FieldDescr ConfigFlags]-configFieldDescrs = - configWriteFieldDescrs+configFieldDescrs :: [FieldDescr SavedConfig]+configFieldDescrs =+ map ( configFlagsField . viewAsFieldDescr) (configureOptions ShowArgs)+ ++ configCabalInstallFieldDescrs ++ map userInstallDirField installDirDescrs ++ map globalInstallDirField installDirDescrs --- | The subset of the config file fields that we write out--- if the config file is missing.-configWriteFieldDescrs :: [FieldDescr ConfigFlags]-configWriteFieldDescrs =- [ simpleField "compiler"- (text . show) parseCompilerFlavor- configCompiler (\c cfg -> cfg { configCompiler = c })- , listField "repos"+configCabalInstallFieldDescrs :: [FieldDescr SavedConfig]+configCabalInstallFieldDescrs =+ [ listField "repos" (text . showRepo) parseRepo- configRepos (\rs cfg -> cfg { configRepos = rs })+ configRemoteRepos (\rs cfg -> cfg { configRemoteRepos = rs }) , simpleField "cachedir"- (text . show) (readS_to_P reads)+ (text . show . fromFlagOrDefault "")+ (fmap emptyToNothing parseFilePathQ) configCacheDir (\d cfg -> cfg { configCacheDir = d })- , boolField "user-install" configUserInstall (\u cfg -> cfg { configUserInstall = u })- ] + , 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 InstallDirTemplates]+installDirDescrs :: [FieldDescr (InstallDirs (Flag PathTemplate))] installDirDescrs =- [ installDirField "prefix" prefixDirTemplate (\d ds -> ds { prefixDirTemplate = d })- , installDirField "bindir" binDirTemplate (\d ds -> ds { binDirTemplate = d })- , installDirField "libdir" libDirTemplate (\d ds -> ds { libDirTemplate = d })- , installDirField "libexecdir" libexecDirTemplate (\d ds -> ds { libexecDirTemplate = d })- , installDirField "datadir" dataDirTemplate (\d ds -> ds { dataDirTemplate = d })- , installDirField "docdir" docDirTemplate (\d ds -> ds { docDirTemplate = d })- , installDirField "htmldir" htmlDirTemplate (\d ds -> ds { htmlDirTemplate = d })+ [ 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 InstallDirTemplates -> FieldDescr ConfigFlags++userInstallDirField :: FieldDescr (InstallDirs (Flag PathTemplate)) -> FieldDescr SavedConfig userInstallDirField f = modifyFieldName ("user-"++) $ liftField configUserInstallDirs (\d cfg -> cfg { configUserInstallDirs = d }) f -globalInstallDirField :: FieldDescr InstallDirTemplates -> FieldDescr ConfigFlags+globalInstallDirField :: FieldDescr (InstallDirs (Flag PathTemplate)) -> FieldDescr SavedConfig globalInstallDirField f = modifyFieldName ("global-"++) $ liftField configGlobalInstallDirs (\d cfg -> cfg { configGlobalInstallDirs = d }) f installDirField :: String - -> (InstallDirTemplates -> PathTemplate) - -> (PathTemplate -> InstallDirTemplates -> InstallDirTemplates)- -> FieldDescr InstallDirTemplates+ -> (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 . show) (readS_to_P reads)+ 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) } -parseCompilerFlavor :: ReadP r CompilerFlavor-parseCompilerFlavor = - do s <- munch1 isAlphaNum- return $ case map toLower s of- "ghc" -> GHC- "nhc" -> NHC- "hugs" -> Hugs- "hbc" -> HBC- "helium" -> Helium- "jhc" -> JHC- _ -> OtherCompiler s--showRepo :: Repo -> String-showRepo repo = repoName repo ++ ":" ++ repoURL repo+showRepo :: RemoteRepo -> String+showRepo repo = remoteRepoName repo ++ ":"+ ++ uriToString id (remoteRepoURI repo) [] -parseRepo :: ReadP r Repo+parseRepo :: ReadP r RemoteRepo parseRepo = do name <- munch1 (\c -> isAlphaNum c || c `elem` "_-.") char ':'- url <- munch1 (\c -> isAlphaNum c || c `elem` "+-=._/*()@'$:;&!?")- return $ Repo { repoName = name, repoURL = url }+ uriStr <- munch1 (\c -> isAlphaNum c || c `elem` "+-=._/*()@'$:;&!?")+ uri <- maybe ReadP.pfail return (parseAbsoluteURI uriStr)+ return $ RemoteRepo {+ remoteRepoName = name,+ remoteRepoURI = uri+ }
Hackage/Dependency.hs view
@@ -1,157 +1,180 @@ ----------------------------------------------------------------------------- -- | -- Module : Hackage.Dependency--- Copyright : (c) David Himmelstrup 2005, Bjorn Bringert 2007+-- Copyright : (c) David Himmelstrup 2005,+-- Bjorn Bringert 2007+-- Duncan Coutts 2008 -- License : BSD-like ----- Maintainer : lemmih@gmail.com+-- Maintainer : cabal-devel@gmail.com -- Stability : provisional -- Portability : portable ----- Various kinds of dependency resolution and utilities.+-- Top level interface to dependency resolution. ------------------------------------------------------------------------------module Hackage.Dependency- (- resolveDependencies- , resolveDependenciesLocal- , packagesToInstall- ) where+module Hackage.Dependency (+ resolveDependencies,+ resolveDependenciesWithProgress,+ PackagesVersionPreference(..),+ upgradableDependencies,+ ) where -import Hackage.Config (listInstalledPackages)-import Hackage.Index (getKnownPackages)-import Hackage.Types - (ResolvedPackage(..), UnresolvedDependency(..), ConfigFlags (..), PkgInfo (..))+--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 Distribution.Version (Dependency(..), withinRange)-import Distribution.Package (PackageIdentifier(..))-import Distribution.PackageDescription - (PackageDescription(buildDepends)- , GenericPackageDescription- , finalizePackageDescription)-import Distribution.Simple.Compiler (Compiler, showCompilerId, compilerVersion)-import Distribution.Simple.Program (ProgramConfiguration)+import Data.List (maximumBy)+import Data.Monoid (Monoid(mempty))+import qualified Data.Set as Set+import Data.Set (Set)+import Control.Exception (assert) -import Control.Monad (mplus)-import Data.Char (toLower)-import Data.List (nub, nubBy, maximumBy, isPrefixOf)-import Data.Maybe (fromMaybe)-import qualified System.Info (arch,os)+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 = -resolveDependencies :: ConfigFlags- -> Compiler- -> ProgramConfiguration- -> [UnresolvedDependency]- -> IO [ResolvedPackage]-resolveDependencies cfg comp conf deps - = do installed <- listInstalledPackages cfg comp conf- available <- getKnownPackages cfg- return [resolveDependency comp installed available dep opts - | UnresolvedDependency dep opts <- deps]+ -- | Always prefer the latest version irrespective of any existing+ -- installed version.+ --+ -- * This is the standard policy for upgrade.+ --+ PreferAllLatest --- | Resolve dependencies of a local package description. This is used--- when the top-level package does not come from hackage.-resolveDependenciesLocal :: ConfigFlags- -> Compiler- -> ProgramConfiguration- -> GenericPackageDescription- -> [String]- -> IO [ResolvedPackage]-resolveDependenciesLocal cfg comp conf desc opts- = do installed <- listInstalledPackages cfg comp conf- available <- getKnownPackages cfg- return [resolveDependency comp installed available dep []- | dep <- getDependencies comp installed available desc opts]+ -- | 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 -resolveDependency :: Compiler- -> [PackageIdentifier] -- ^ Installed packages.- -> [PkgInfo] -- ^ Installable packages- -> Dependency- -> [String] -- ^ Options for this dependency- -> ResolvedPackage-resolveDependency comp installed available dep opts- = fromMaybe (Unavailable dep) $ resolveFromInstalled `mplus` resolveFromAvailable- where- resolveFromInstalled = fmap (Installed dep) $ latestInstalledSatisfying installed dep- resolveFromAvailable = - do pkg <- latestAvailableSatisfying available dep- let deps = getDependencies comp installed available (pkgDesc pkg) opts- resolved = map (\d -> resolveDependency comp installed available d []) deps- return $ Available dep pkg opts resolved+ -- | 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 --- | Gets the latest installed package satisfying a dependency.-latestInstalledSatisfying :: [PackageIdentifier] - -> Dependency -> Maybe PackageIdentifier-latestInstalledSatisfying = latestSatisfying id+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 --- | Gets the latest available package satisfying a dependency.-latestAvailableSatisfying :: [PkgInfo] - -> Dependency -> Maybe PkgInfo-latestAvailableSatisfying = latestSatisfying pkgInfoId+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 -latestSatisfying :: (a -> PackageIdentifier) - -> [a]- -> Dependency- -> Maybe a-latestSatisfying f xs dep =- case filter ((`satisfies` dep) . f) xs of- [] -> Nothing- ys -> Just $ maximumBy (comparing (pkgVersion . f)) ys- where comparing g a b = g a `compare` g b+resolveDependenciesWithProgress os arch comp Nothing =+ dependencyResolver bogusResolver os arch comp mempty --- | Checks if a package satisfies a dependency.-satisfies :: PackageIdentifier -> Dependency -> Bool-satisfies pkg (Dependency depName vrange)- = pkgName pkg == depName && pkgVersion pkg `withinRange` vrange+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 --- | Gets the dependencies of an available package.-getDependencies :: Compiler - -> [PackageIdentifier] -- ^ Installed packages.- -> [PkgInfo] -- ^ Available packages- -> GenericPackageDescription- -> [String] -- ^ Options- -> [Dependency] - -- ^ If successful, this is the list of dependencies.- -- If flag assignment failed, this is the list of- -- missing dependencies.-getDependencies comp installed available pkg opts- = case e of- Left missing -> missing- Right (desc,_) -> buildDepends desc- where - flags = configurationsFlags opts- e = finalizePackageDescription - flags- (Just $ nub $ installed ++ map pkgInfoId available) - System.Info.os- System.Info.arch- (showCompilerId comp, compilerVersion comp)- pkg+hideBasePackage :: Package p => PackageIndex p -> PackageIndex p+hideBasePackage = PackageIndex.deletePackageName "base"+ . PackageIndex.deletePackageName "ghc-prim" --- | Extracts configurations flags from a list of options.-configurationsFlags :: [String] -> [(String, Bool)]-configurationsFlags = concatMap flag- where- flag o | "--flags=" `isPrefixOf` o = map tagWithValue $ words $ removeQuotes $ drop 8 o- | "-f" `isPrefixOf` o = [tagWithValue $ drop 2 o]- | otherwise = []- removeQuotes (c:s) | c == '"' || c == '\'' = take (length s - 1) s- removeQuotes s = s- tagWithValue ('-':name) = (map toLower name, False)- tagWithValue name = (map toLower name, True)+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 -packagesToInstall :: [ResolvedPackage] - -> Either [Dependency] [(PkgInfo, [String])]- -- ^ Either a list of missing dependencies, or a list- -- of packages to install, with their options.-packagesToInstall xs | null missing = Right toInstall- | otherwise = Left missing- where - flattened = concatMap flatten xs- missing = [d | Left d <- flattened]- toInstall = nubBy samePackage [x | Right x <- flattened]- samePackage a b = pkgInfoId (fst a) == pkgInfoId (fst b)- flatten (Installed _ _) = []- flatten (Available _ p opts deps) = concatMap flatten deps ++ [Right (p,opts)]- flatten (Unavailable dep) = [Left dep]+ 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 view
@@ -0,0 +1,73 @@+-----------------------------------------------------------------------------+-- |+-- 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 for when we do not know what packages are installed.+-----------------------------------------------------------------------------+module Hackage.Dependency.Bogus (+ bogusResolver+ ) where++import qualified Distribution.Simple.PackageIndex as PackageIndex+import Distribution.Simple.PackageIndex (PackageIndex)+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.Configuration+ ( finalizePackageDescription)+import Distribution.Simple.Utils (comparing)+import Hackage.Utils+ ( showDependencies )++import Data.List (maximumBy)++-- | 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 _ deps =+ case unzipEithers (map resolveFromAvailable deps) of+ (ok, []) -> Done ok+ (_ , missing) -> Fail $ "Unresolved dependencies: "+ ++ showDependencies missing+ where+ resolveFromAvailable (UnresolvedDependency dep flags) =+ case latestAvailableSatisfying available dep of+ Nothing -> Right dep+ Just apkg@(AvailablePackage _ pkg _) ->+ case finalizePackageDescription flags none os arch comp [] pkg of+ Right (_, flags') -> Left $ InstallPlan.Configured $+ ConfiguredPackage apkg flags' []+ --TODO: we have to add PreExisting deps of pkg, otherwise+ -- the install plan verifier will say we're missing deps.+ _ -> error "bogusResolver: impossible happened"+ where+ none :: Maybe (PackageIndex PackageIdentifier)+ none = Nothing++-- | 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)++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/Naive.hs view
@@ -0,0 +1,180 @@+-----------------------------------------------------------------------------+-- |+-- 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 view
@@ -0,0 +1,598 @@+-----------------------------------------------------------------------------+-- |+-- 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 view
@@ -0,0 +1,244 @@+-----------------------------------------------------------------------------+-- |+-- 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 view
@@ -0,0 +1,90 @@+-----------------------------------------------------------------------------+-- |+-- 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 view
@@ -0,0 +1,90 @@+-----------------------------------------------------------------------------+-- |+-- 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 view
@@ -17,119 +17,152 @@ , -- * Utilities fetchPackage , isFetched- , readURI , downloadIndex ) where -import Network.URI (URI,parseURI,uriScheme,uriPath)-import Network.HTTP (ConnError(..), Request (..), simpleHTTP- , Response(..), RequestMethod (..))+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 qualified Hackage.IndexUtils as IndexUtils+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 Data.Monoid (Monoid(mconcat)) import Control.Exception (bracket) import Control.Monad (filterM)-import Text.Printf (printf) import System.Directory (doesFileExist, createDirectoryIfMissing)--import Hackage.Types (ConfigFlags (..), UnresolvedDependency (..), Repo(..), PkgInfo, pkgInfoId)-import Hackage.Config (repoCacheDir, packageFile, packageDir, pkgURL, message)-import Hackage.Dependency (resolveDependencies, packagesToInstall)-import Hackage.Utils--import Distribution.Package (showPackageId)-import Distribution.Simple.Compiler (Compiler)-import Distribution.Simple.Program (ProgramConfiguration)-import Distribution.Verbosity import System.FilePath ((</>), (<.>)) import System.Directory (copyFile) import System.IO (IOMode(..), hPutStr, Handle, hClose, openBinaryFile) -readURI :: URI -> IO String-readURI uri- | uriScheme uri == "file:" = (readFile $ uriPath uri)- | otherwise = do- eitherResult <- simpleHTTP (Request uri GET [] "")- case eitherResult of- Left err -> fail $ printf "Failed to download '%s': %s" (show uri) (show err)- Right rsp- | rspCode rsp == (2,0,0) -> return (rspBody rsp)- | otherwise -> fail $ "Failed to download '" ++ show uri ++ "': Invalid HTTP code: " ++ show (rspCode rsp)--downloadURI :: FilePath -- ^ Where to put it+downloadURI :: Verbosity+ -> FilePath -- ^ Where to put it -> URI -- ^ What to download -> IO (Maybe ConnError)-downloadURI path uri+downloadURI verbosity path uri | uriScheme uri == "file:" = do copyFile (uriPath uri) path return Nothing | otherwise = do- eitherResult <- simpleHTTP request+ 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))))- where request = Request uri GET [] "" ---downloadFile :: FilePath- -> String- -> IO (Maybe ConnError)-downloadFile path url- = case parseURI url of- Just parsed -> downloadURI path parsed- Nothing -> return (Just (ErrorMisc ("Failed to parse url: " ++ show url)))-- -- Downloads a package to [config-dir/packages/package-id] and returns the path to the package.-downloadPackage :: ConfigFlags -> PkgInfo -> IO String-downloadPackage cfg pkg- = do let url = pkgURL pkg- dir = packageDir cfg pkg- path = packageFile cfg pkg- message cfg verbose $ "GET " ++ show url+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 <- downloadFile path url+ mbError <- downloadURI verbosity path uri case mbError of- Just err -> fail $ printf "Failed to download '%s': %s" (showPackageId (pkgInfoId pkg)) (show err)+ 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 :: ConfigFlags -> Repo -> IO FilePath-downloadIndex cfg repo- = do let url = repoURL repo ++ "/" ++ "00-index.tar.gz"- dir = repoCacheDir cfg repo+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 <- downloadFile path url+ mbError <- downloadURI verbosity path uri case mbError of- Just err -> fail $ printf "Failed to download index '%s'" (show err)+ Just err -> die $ "Failed to download index '" ++ show err ++ "'" Nothing -> return path -- |Returns @True@ if the package has already been fetched.-isFetched :: ConfigFlags -> PkgInfo -> IO Bool-isFetched cfg pkg = doesFileExist (packageFile cfg pkg)+isFetched :: AvailablePackage -> IO Bool+isFetched pkg = doesFileExist (packageFile pkg) -- |Fetch a package if we don't have it already.-fetchPackage :: ConfigFlags -> PkgInfo -> IO String-fetchPackage cfg pkg- = do fetched <- isFetched cfg pkg+fetchPackage :: Verbosity -> AvailablePackage -> IO String+fetchPackage verbosity pkg+ = do fetched <- isFetched pkg if fetched- then do printf "'%s' is cached.\n" (showPackageId (pkgInfoId pkg))- return (packageFile cfg pkg)- else do printf "Downloading '%s'...\n" (showPackageId (pkgInfoId pkg))- downloadPackage cfg pkg+ 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 :: ConfigFlags -> Compiler -> ProgramConfiguration -> [String] -> [UnresolvedDependency] -> IO ()-fetch cfg comp conf _globalArgs deps- = do depTree <- resolveDependencies cfg comp conf deps- case packagesToInstall depTree of- Left missing -> fail $ "Unresolved dependencies: " ++ showDependencies missing- Right pkgs -> do ps <- filterM (fmap not . isFetched cfg) $ map fst pkgs- mapM_ (fetchPackage cfg) ps+fetch :: Verbosity+ -> PackageDB+ -> [Repo]+ -> Compiler+ -> ProgramConfiguration+ -> [UnresolvedDependency]+ -> IO ()+fetch verbosity packageDB repos comp conf deps+ = do installed <- getInstalledPackages verbosity comp packageDB conf+ available <- fmap mconcat (mapM (IndexUtils.readRepoIndex 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 :: 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 view
@@ -0,0 +1,94 @@+{-# 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 (..), parseURI)+import Network.Stream (Result)+import Network.Browser (Proxy (..), Authority (..), browse,+ setOutHandler, setErrHandler, setProxy, request)+import Control.Monad (mplus)+#ifdef WIN32+import System.Win32.Registry (hKEY_CURRENT_USER, regOpenKey, regQueryValue, regCloseKey)+import Control.Exception (try, bracket)+#endif+import System.Environment (getEnvironment)++import qualified Paths_cabal_install (version)+import Distribution.Verbosity (Verbosity)+import Distribution.Simple.Utils (warn, debug)+import Distribution.Text+ ( display )++-- 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 = fmap (either (const Nothing) Just) $ try $+ bracket (regOpenKey hive path) regCloseKey+ (\hkey -> regQueryValue hkey (Just "ProxyServer"))+ 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"+#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 parseURI str of+ Nothing -> do warn verbosity $ "invalid proxy uri: " ++ show str+ warn verbosity $ "ignoring http proxy, trying a direct connection"+ return NoProxy+ Just uri -> case uri2proxy uri 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++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/Index.hs
@@ -1,64 +0,0 @@--------------------------------------------------------------------------------- |--- Module : Hackage.Index--- Copyright : (c) David Himmelstrup 2005, Bjorn Bringert 2007--- License : BSD-like------ Maintainer : lemmih@gmail.com--- Stability : provisional--- Portability : portable------ Reading the local package index.-------------------------------------------------------------------------------module Hackage.Index (getKnownPackages) where--import Hackage.Config-import Hackage.Types-import Hackage.Tar--import Prelude hiding (catch)-import Control.Exception (catch, Exception(IOException))-import qualified Data.ByteString.Lazy.Char8 as BS-import Data.ByteString.Lazy.Char8 (ByteString)-import System.FilePath ((</>), takeExtension, splitDirectories, normalise)-import System.IO (hPutStrLn, stderr)-import System.IO.Error (isDoesNotExistError)--import Distribution.PackageDescription (parsePackageDescription, ParseResult(..))-import Distribution.Package (PackageIdentifier(..))-import Distribution.Version (readVersion)--getKnownPackages :: ConfigFlags -> IO [PkgInfo]-getKnownPackages cfg- = fmap concat $ mapM (readRepoIndex cfg) $ configRepos cfg--readRepoIndex :: ConfigFlags -> Repo -> IO [PkgInfo]-readRepoIndex cfg repo =- do let indexFile = repoCacheDir cfg repo </> "00-index.tar"- fmap (parseRepoIndex repo) (BS.readFile indexFile)- `catch` (\e -> do case e of- IOException ioe | isDoesNotExistError ioe ->- hPutStrLn stderr "The package list does not exist. Run 'cabal update' to download it."- _ -> hPutStrLn stderr ("Error: " ++ show e)- return [])--parseRepoIndex :: Repo -> ByteString -> [PkgInfo]-parseRepoIndex repo s =- do (hdr, content) <- readTarArchive s- if takeExtension (tarFileName hdr) == ".cabal"- then case splitDirectories (normalise (tarFileName hdr)) of- [pkgname,vers,_] ->- let descr = case parsePackageDescription (BS.unpack content) of- ParseOk _ d -> d- _ -> error $ "Couldn't read cabal file "- ++ show (tarFileName hdr)- in case readVersion vers of- Just ver ->- return $ PkgInfo {- pkgInfoId = PackageIdentifier pkgname ver,- pkgRepo = repo,- pkgDesc = descr- }- _ -> []- _ -> []- else []
+ Hackage/IndexUtils.hs view
@@ -0,0 +1,119 @@+-----------------------------------------------------------------------------+-- |+-- 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 (+ 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, intercalate, fromUTF8)++import Prelude hiding (catch)+import Control.Exception (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)++-- | 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/Info.hs
@@ -1,64 +0,0 @@--------------------------------------------------------------------------------- |--- Module : Hackage.Info--- Copyright : (c) David Himmelstrup 2005--- License : BSD-like------ Maintainer : lemmih@gmail.com--- Stability : provisional--- Portability : portable------ High level interface to a dry-run package installation.-------------------------------------------------------------------------------module Hackage.Info where--import Hackage.Config-import Hackage.Dependency -import Hackage.Fetch-import Hackage.Types -import Hackage.Utils--import Distribution.Package (showPackageId)-import Distribution.ParseUtils (showDependency)-import Distribution.Simple.Compiler (Compiler)-import Distribution.Simple.Program (ProgramConfiguration)--import Data.List (intersperse, nubBy)-import Text.Printf (printf)--info :: ConfigFlags -> Compiler -> ProgramConfiguration -> [String] -> [UnresolvedDependency] -> IO ()-info cfg comp conf _globalArgs deps- = do apkgs <- resolveDependencies cfg comp conf deps- mapM_ (infoPkg cfg) $ flattenResolvedPackages apkgs- case packagesToInstall apkgs of- Left missing -> - do putStrLn "The requested packages cannot be installed, because of missing dependencies:"- putStrLn $ showDependencies missing- Right pkgs ->- do putStrLn "These packages would be installed:"- putStrLn $ concat $ intersperse ", " [showPackageId (pkgInfoId pkg) | (pkg,_) <- pkgs]- --flattenResolvedPackages :: [ResolvedPackage] -> [ResolvedPackage]-flattenResolvedPackages = nubBy fulfillSame. concatMap flatten- where flatten p@(Available _ _ _ deps) = p : flattenResolvedPackages deps- flatten p = [p]- fulfillSame a b = fulfills a == fulfills b--infoPkg :: ConfigFlags -> ResolvedPackage -> IO ()-infoPkg _ (Installed dep p)- = do printf " Requested: %s\n" (show $ showDependency dep)- printf " Installed: %s\n\n" (showPackageId p)-infoPkg cfg (Available dep pkg opts deps)- = do fetched <- isFetched cfg pkg- let pkgFile = if fetched then packageFile cfg pkg- else "*Not downloaded"- printf " Requested: %s\n" (show $ showDependency dep)- printf " Using: %s\n" (showPackageId (pkgInfoId pkg))- printf " Depends: %s\n" (showDependencies $ map fulfills deps)- printf " Options: %s\n" (unwords opts)- printf " Location: %s\n" (pkgURL pkg)- printf " Local: %s\n\n" pkgFile-infoPkg _ (Unavailable dep)- = do printf " Requested: %s\n" (show $ showDependency dep)- printf " Not available!\n\n"
Hackage/Install.hs view
@@ -10,159 +10,339 @@ -- -- High level interface to package installation. ------------------------------------------------------------------------------module Hackage.Install- ( install- ) where+module Hackage.Install (+ install,+ upgrade,+ ) where -import Control.Exception (bracket_)-import Control.Monad (when)-import System.Directory (getTemporaryDirectory, createDirectoryIfMissing- ,removeDirectoryRecursive, doesFileExist)+import Data.List+ ( unfoldr )+import Data.Monoid (Monoid(mconcat))+import Control.Exception as Exception+ ( handle, Exception )+import Control.Monad+ ( when, unless )+import System.Directory+ ( getTemporaryDirectory, doesFileExist ) import System.FilePath ((</>),(<.>)) -import Text.Printf (printf)---import Hackage.Config (message)-import Hackage.Dependency (resolveDependencies, resolveDependenciesLocal, packagesToInstall)+import Hackage.Dependency+ ( resolveDependenciesWithProgress, PackagesVersionPreference(..)+ , upgradableDependencies )+import Hackage.Dependency.Types (Progress(..), foldProgress) import Hackage.Fetch (fetchPackage)+-- import qualified Hackage.Info as Info+import qualified Hackage.IndexUtils as IndexUtils+import qualified Hackage.InstallPlan as InstallPlan+import Hackage.InstallPlan (InstallPlan)+import Hackage.Setup+ ( InstallFlags(..), configureCommand, filterConfigureFlags ) import Hackage.Tar (extractTarGzFile)-import Hackage.Types (ConfigFlags(..), UnresolvedDependency(..)- , PkgInfo(..))-import Hackage.Utils+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(..))-import Distribution.Simple.InstallDirs (InstallDirs(..), absoluteInstallDirs)-import Distribution.Simple.Program (ProgramConfiguration)-import Distribution.Simple.SetupWrapper (setupWrapper)-import Distribution.Simple.Setup (CopyDest(..))-import Distribution.Simple.Utils (defaultPackageDesc)-import Distribution.Package (showPackageId, PackageIdentifier(..))-import Distribution.PackageDescription (packageDescription, readPackageDescription, package)-import Distribution.Verbosity+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(..), Dependency(..) )+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 --- |Installs the packages needed to satisfy a list of dependencies.-install :: ConfigFlags -> Compiler -> ProgramConfiguration -> [String] -> [UnresolvedDependency] -> IO ()-install cfg comp conf globalArgs deps- | null deps = installLocalPackage cfg comp conf globalArgs- | otherwise = installRepoPackages cfg comp conf globalArgs deps+type Planner = Maybe (PackageIndex InstalledPackageInfo)+ -> PackageIndex AvailablePackage+ -> IO (Progress String String (InstallPlan BuildResult)) --- | Install the unpacked package in the current directory, and all its dependencies.-installLocalPackage :: ConfigFlags -> Compiler -> ProgramConfiguration -> [String] -> IO ()-installLocalPackage cfg comp conf globalArgs =- do cabalFile <- defaultPackageDesc (configVerbose cfg)- desc <- readPackageDescription (configVerbose cfg) cabalFile- resolvedDeps <- resolveDependenciesLocal cfg comp conf desc globalArgs- case packagesToInstall resolvedDeps of- Left missing -> fail $ "Unresolved dependencies: " ++ showDependencies missing- Right pkgs -> installPackages cfg comp globalArgs pkgs- let pkgId = package (packageDescription desc)- installUnpackedPkg cfg comp globalArgs pkgId [] Nothing+-- |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 <- fmap mconcat (mapM (IndexUtils.readRepoIndex verbosity) repos) -installRepoPackages :: ConfigFlags -> Compiler -> ProgramConfiguration -> [String] -> [UnresolvedDependency] -> IO ()-installRepoPackages cfg comp conf globalArgs deps =- do resolvedDeps <- resolveDependencies cfg comp conf deps- case packagesToInstall resolvedDeps of- Left missing -> fail $ "Unresolved dependencies: " ++ showDependencies missing- Right [] -> message cfg normal "All requested packages already installed. Nothing to do."- Right pkgs -> installPackages cfg comp globalArgs pkgs+ progress <- planner installed available --- Attach the correct prefix flag to configure commands,--- correct --user flag to install commands and no options to other commands.-mkPkgOps :: ConfigFlags -> Compiler -> PackageIdentifier -> String -> [String] -> [String]-mkPkgOps cfg comp pkgId cmd ops = verbosity ++- case cmd of- "configure" -> user ++ hcPath ++ hcPkgPath ++ installDirFlags installDirs ++ ops- "install" -> user- _ -> []- where verbosity = ["-v" ++ showForCabal (configVerbose cfg)]- user = if configUserInstall cfg then ["--user"] else []- hcPath = maybe [] (\path -> ["--with-compiler=" ++ path]) (configCompilerPath cfg)- hcPkgPath = maybe [] (\path -> ["--with-hc-pkg=" ++ path]) (configHcPkgPath cfg)- installDirTemplates | configUserInstall cfg = configUserInstallDirs cfg- | otherwise = configGlobalInstallDirs cfg- installDirs = absoluteInstallDirs pkgId (compilerId comp) NoCopyDest installDirTemplates+ 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 -installDirFlags :: InstallDirs FilePath -> [String]-installDirFlags dirs =- [flag "prefix" prefix,- flag "bindir" bindir,- flag "libdir" libdir,--- flag "dynlibdir" dynlibdir, -- not accepted as argument by cabal?- flag "libexecdir" libexecdir,--- flag "progdir" progdir, -- not accepted as argument by cabal?--- flag "includedir" includedir, -- not accepted as argument by cabal?- flag "datadir" datadir,- flag "docdir" docdir,- flag "htmldir" htmldir]- where flag s f = "--" ++ s ++ "=" ++ f dirs+ 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' -installPackages :: ConfigFlags- -> Compiler- -> [String] -- ^Options which will be parse to every package.- -> [(PkgInfo,[String])] -- ^ (Package, list of configure options)- -> IO ()-installPackages cfg comp globalArgs pkgs =- mapM_ (installPkg cfg comp globalArgs) pkgs+ 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 = let PackageIdentifier n v = packageId localPkg+ in Dependency n (ThisVersion v),+ depFlags = Cabal.configConfigurationsFlags configFlags+ } -{-|- Download, build and install a given package with some given flags.+ return $ resolveDependenciesWithProgress buildOS buildArch (compilerId comp)+ installed' available' PreferLatestForSelected [localPkgDep] - The process is divided up in a few steps:+-- | 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' - * The package is downloaded to {config-dir}\/packages\/{pkg-id} (if not already there).+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." - * The fetched tarball is then moved to a temporary directory (\/tmp on linux) and unpacked.+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 - * setupWrapper (equivalent to cabal-setup) is called with the options- \'configure\' and the user specified options, \'--user\'- if the 'configUser' flag is @True@ and install directory flags depending on - @configUserInstallDirs@ or @configGlobalInstallDirs@.+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+ _ -> "" - * setupWrapper \'build\' is called with no options.+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 - * setupWrapper \'install\' is called with the \'--user\' flag if 'configUserInstall' is @True@.+-- | 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 = [ Dependency name (ThisVersion version)+ | PackageIdentifier name version <- deps ]+ } pkg - * The installation finishes by deleting the unpacked tarball.--} -installPkg :: ConfigFlags- -> Compiler- -> [String] -- ^Options which will be parse to every package.- -> (PkgInfo,[String]) -- ^(Package, list of configure options)- -> IO ()-installPkg cfg comp globalArgs (pkg,opts)- = do pkgPath <- fetchPackage cfg pkg- tmp <- getTemporaryDirectory- let p = pkgInfoId pkg- tmpDirPath = tmp </> printf "TMP%sTMP" (showPackageId p)- path = tmpDirPath </> showPackageId p- bracket_ (createDirectoryIfMissing True tmpDirPath)- (removeDirectoryRecursive tmpDirPath)- (do message cfg verbose (printf "Extracting %s to %s..." pkgPath tmpDirPath)- extractTarGzFile (Just tmpDirPath) pkgPath- let descFilePath = tmpDirPath </> showPackageId p </> pkgName p <.> "cabal"- e <- doesFileExist descFilePath- when (not e) $ fail $ "Package .cabal file not found: " ++ show descFilePath- installUnpackedPkg cfg comp globalArgs p opts (Just path)- return ())+installAvailablePackage+ :: Verbosity -> AvailablePackage+ -> (GenericPackageDescription -> Maybe FilePath -> IO BuildResult)+ -> IO BuildResult+installAvailablePackage _ (AvailablePackage _ pkg LocalUnpackedPackage)+ installPkg = installPkg pkg Nothing -installUnpackedPkg :: ConfigFlags -> Compiler - -> [String] -- ^ Arguments for all packages- -> PackageIdentifier- -> [String] -- ^ Arguments for this package+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 ()-installUnpackedPkg cfg comp globalArgs pkgId opts mpath- = do setup "configure"- setup "build"- setup "install"+ -> 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- setup cmd - = do let cmdOps = mkPkgOps cfg comp pkgId cmd (globalArgs++opts)- message cfg verbose $ - unwords ["setupWrapper", show (cmd:cmdOps), show mpath]- setupWrapper (cmd:cmdOps) mpath+ 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 view
@@ -0,0 +1,497 @@+-----------------------------------------------------------------------------+-- |+-- 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 view
@@ -10,55 +10,173 @@ -- -- High level interface to package installation. ------------------------------------------------------------------------------module Hackage.List- ( list -- :: ConfigFlags -> [UnresolvedDependency] -> IO ()- ) where+module Hackage.List (+ list+ ) where -import Data.List (nubBy, sortBy, groupBy, intersperse, isPrefixOf, tails)-import Data.Char as Char (toLower)-import Distribution.Package-import Distribution.PackageDescription-import Distribution.Version (showVersion)-import Hackage.Index (getKnownPackages)-import Hackage.Types (PkgInfo(..), ConfigFlags(..), {- UnresolvedDependency(..)-} )+import Data.List (sortBy, groupBy, sort, nub, intersperse)+import Data.Maybe (listToMaybe, fromJust)+import Data.Monoid (Monoid(mconcat))+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 qualified Hackage.IndexUtils as IndexUtils (readRepoIndex)+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 :: ConfigFlags -> [String] -> IO ()-list cfg pats = do- pkgs <- getKnownPackages cfg- let pkgs' | null pats = pkgs- | otherwise = nubBy samePackage (concatMap (findInPkgs pkgs) pats')- pats' = map lcase pats- putStrLn- . unlines- . map (showPkgVersions . map (packageDescription . pkgDesc))- . groupBy sameName- . sortBy (comparing nameAndVersion)- $ pkgs'+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 <- fmap mconcat (mapM (IndexUtils.readRepoIndex 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- findInPkgs :: [PkgInfo] -> String -> [PkgInfo]- findInPkgs pkgs pat =- filter (isInfixOf pat . lcase . pkgName . pkgInfoId) pkgs- lcase = map Char.toLower- nameAndVersion p = (lcase name, name, version)- where name = pkgName (pkgInfoId p)- version = pkgVersion (pkgInfoId p)- samePackage a b = nameAndVersion a == nameAndVersion b- sameName a b = pkgName (pkgInfoId a) == pkgName (pkgInfoId b)+ installedFilter+ | onlyInstalled = filter (not . null . installedVersions)+ | otherwise = id+ onlyInstalled = fromFlag (listInstalled listFlags)+ simpleOutput = fromFlag (listSimpleOutput listFlags) -showPkgVersions :: [PackageDescription] -> String-showPkgVersions pkgs =- padTo 35 (pkgName (package pkg)- ++ " [" ++ concat (intersperse ", " versions) ++ "] ")- ++ synopsis pkg+-- | The info that we can display for each package. It is information per+-- package name and covers all installed and avilable versions.+--+data PackageDisplayInfo = PackageDisplayInfo {+ 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- pkg = last pkgs- versions = map (showVersion . pkgVersion . package) pkgs- padTo n s = s ++ (replicate (n - length s) ' ')+ 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 -comparing :: (Ord a) => (b -> a) -> b -> b -> Ordering-comparing p x y = compare (p x) (p y)+-- | 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)) -isInfixOf :: String -> String -> Bool-isInfixOf needle haystack = any (isPrefixOf needle) (tails haystack)+-- | 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 view
@@ -0,0 +1,82 @@+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 view
@@ -0,0 +1,318 @@+-----------------------------------------------------------------------------+-- |+-- 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 view
@@ -11,194 +11,360 @@ -- ----------------------------------------------------------------------------- module Hackage.Setup- ( parsePackageArgs- , parseGlobalArgs- , configFromOptions+ ( globalCommand, Cabal.GlobalFlags(..)+ , configureCommand, filterConfigureFlags+ , installCommand, InstallFlags(..)+ , listCommand, ListFlags(..)+ , updateCommand+ , upgradeCommand+ , infoCommand+ , fetchCommand+ , checkCommand+ , uploadCommand, UploadFlags(..)++ , parsePackageArgs ) where -import Control.Monad (when)-import Distribution.Compiler (CompilerFlavor(..))-import Distribution.Simple.InstallDirs (InstallDirTemplates(..), toPathTemplate)-import Distribution.Verbosity-import Data.List (find)-import System.Console.GetOpt (ArgDescr (..), ArgOrder (..), OptDescr (..), usageInfo, getOpt')-import System.Exit (exitWith, ExitCode (..))-import System.Environment (getProgName)+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 (Action (..), Option(..), ConfigFlags(..)- , UnresolvedDependency (..))-import Hackage.Utils (readPToMaybe, parseDependencyOrPackageId)+import Hackage.Types+ ( Username(..), Password(..) )+import Hackage.ParseUtils (readPToMaybe, parseDependencyOrPackageId) +import Data.Monoid (Monoid(..)) -globalOptions :: [OptDescr Option]-globalOptions =- [ Option "g" ["ghc"] (NoArg (OptCompilerFlavor GHC)) "Compile with GHC"- , Option "n" ["nhc"] (NoArg (OptCompilerFlavor NHC)) "Compile with NHC"- , Option "" ["hugs"] (NoArg (OptCompilerFlavor Hugs)) "Compile with hugs"- , Option "w" ["with-compiler"] (reqPathArg OptCompiler)- "Give the path to a particular compiler"- , Option "" ["with-hc-pkg"] (reqPathArg OptHcPkg)- "Give the path to the package tool"- , Option "c" ["config-file"] (reqPathArg OptConfigFile)- ("Override the path to the config dir.")- , Option "" ["cache-dir"] (reqPathArg OptCacheDir)- ("Override the path to the package cache dir.")- , Option "" ["prefix"] (reqDirArg OptPrefix)- "Bake this prefix in preparation of installation"- , Option "" ["bindir"] (reqDirArg OptBinDir)- "Installation directory for executables"- , Option "" ["libdir"] (reqDirArg OptLibDir)- "Installation directory for libraries"- , Option "" ["libsubdir"] (reqDirArg OptLibSubDir)- "Subdirectory of libdir in which libs are installed"- , Option "" ["libexecdir"] (reqDirArg OptLibExecDir)- "Installation directory for program executables"- , Option "" ["datadir"] (reqDirArg OptDataDir)- "Installation directory for read-only data"- , Option "" ["datasubdir"] (reqDirArg OptDataSubDir)- "Subdirectory of datadir in which data files are installed"- , Option "" ["docdir"] (reqDirArg OptDocDir)- "Installation directory for documentation"- , Option "" ["htmldir"] (reqDirArg OptHtmlDir)- "Installation directory for HTML documentation"- , Option "" ["user"] (NoArg (OptUserInstall True))- "Upon registration, register this package in the user's local package database"- , Option "" ["global"] (NoArg (OptUserInstall False))- "Upon registration, register this package in the system-wide package database"- , Option "h?" ["help"] (NoArg OptHelp) "Show this help text"- , Option "v" ["verbose"] (OptArg (OptVerbose . flagToVerbosity) "n")- "Control verbosity (n is 0--3, normal verbosity level is 1, -v alone is equivalent to -v2)"- ]+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"+ } -reqPathArg :: (FilePath -> a) -> ArgDescr a-reqPathArg constr = ReqArg constr "PATH"+configureCommand :: CommandUI Cabal.ConfigFlags+configureCommand = (Cabal.configureCommand defaultProgramConfiguration) {+ commandDefaultFlags = mempty+ } -reqDirArg :: (FilePath -> a) -> ArgDescr a-reqDirArg constr = ReqArg constr "DIR"+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 = [] } -configFromOptions :: ConfigFlags -> [Option] -> ConfigFlags-configFromOptions conf opts = foldr f conf opts- where - -- figure out up front if this is a user or global install- userInstall = last $ configUserInstall conf : [u | OptUserInstall u <- opts]- f o cfg = case o of- OptCompilerFlavor c -> cfg { configCompiler = c}- OptCompiler p -> cfg { configCompilerPath = Just p }- OptHcPkg p -> cfg { configHcPkgPath = Just p }- OptConfigFile _ -> cfg- OptCacheDir d -> cfg { configCacheDir = d }- OptPrefix d -> lib (\ds x -> ds { prefixDirTemplate = x }) d- OptBinDir d -> lib (\ds x -> ds { binDirTemplate = x }) d- OptLibDir d -> lib (\ds x -> ds { libDirTemplate = x }) d- OptLibSubDir d -> lib (\ds x -> ds { libSubdirTemplate = x }) d- OptLibExecDir d -> lib (\ds x -> ds { libexecDirTemplate = x }) d- OptDataDir d -> lib (\ds x -> ds { dataDirTemplate = x }) d- OptDataSubDir d -> lib (\ds x -> ds { dataSubdirTemplate = x }) d- OptDocDir d -> lib (\ds x -> ds { docDirTemplate = x }) d- OptHtmlDir d -> lib (\ds x -> ds { htmlDirTemplate = x }) d- OptUserInstall u -> cfg { configUserInstall = u }- OptHelp -> error "Got to setFlagsFromOptions OptHelp"- OptVerbose v -> cfg { configVerbose = v }- where - -- This is a bit of a hack to allow just one set of installdir command-line- -- options. Settings on the comman-line are for a single install session only,- -- which will be either a user or global install.- lib g d | userInstall = cfg { configUserInstallDirs = g (configUserInstallDirs cfg) d' }- | otherwise = cfg { configGlobalInstallDirs = g (configGlobalInstallDirs cfg) d' }- where d' = toPathTemplate d -data Cmd = Cmd {- cmdName :: String,- cmdHelp :: String, -- Short description- cmdDescription :: String, -- Long description- cmdOptions :: [OptDescr Option],- cmdAction :: Action- }+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]+ } -commandList :: [Cmd]-commandList = [fetchCmd, installCmd, updateCmd, cleanCmd, listCmd, infoCmd]+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]+ } -lookupCommand :: String -> Maybe Cmd-lookupCommand name = find ((==name) . cmdName) commandList+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]+ } -printGlobalHelp :: IO ()-printGlobalHelp = do pname <- getProgName- let syntax_line = concat [ "Usage: ", pname- , " [GLOBAL FLAGS]\n or: ", pname- , " COMMAND [FLAGS]\n\nGlobal flags:"]- putStrLn (usageInfo syntax_line globalOptions)- putStrLn "Commands:"- let maxlen = maximum [ length (cmdName cmd) | cmd <- commandList ]- sequence_ [ do putStr " "- putStr (align maxlen (cmdName cmd))- putStr " "- putStrLn (cmdHelp cmd)- | cmd <- commandList ]- where align n str = str ++ replicate (n - length str) ' '+{-+cleanCommand :: CommandUI ()+cleanCommand = makeCommand name shortDesc longDesc emptyFlags options+ where+ name = "clean"+ shortDesc = "Removes downloaded files"+ longDesc = Nothing+ emptyFlags = ()+ options _ = []+-} -parseGlobalArgs :: [String] -> IO (Action,[Option],[String])-parseGlobalArgs opts =- do let (flags, args, unrec, errs) = getOpt' RequireOrder globalOptions opts- when (OptHelp `elem` flags) $ - do printGlobalHelp- exitWith ExitSuccess- when (not (null errs)) $ - do putStrLn "Errors:"- mapM_ putStrLn errs- exitWith (ExitFailure 1)- when (not (null unrec)) $ - do putStrLn "Unrecognized options:"- mapM_ putStrLn unrec- exitWith (ExitFailure 1)- case args of- [] -> do putStrLn $ "No command given (try --help)"- exitWith (ExitFailure 1)- cname:cargs -> case lookupCommand cname of- Just cmd -> return (cmdAction cmd, flags, cargs)- Nothing -> do putStrLn $ "Unrecognised command: " ++ cname ++ " (try --help)"- exitWith (ExitFailure 1)+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]+ } -mkCmd :: String -> String -> String -> Action -> Cmd-mkCmd name help desc action =- Cmd { cmdName = name- , cmdHelp = help- , cmdDescription = desc- , cmdOptions = []- , cmdAction = action- }+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+ } -fetchCmd :: Cmd-fetchCmd = mkCmd "fetch" "Downloads packages for later installation or study." "" FetchCmd+-- ------------------------------------------------------------+-- * List flags+-- ------------------------------------------------------------ -installCmd :: Cmd-installCmd = mkCmd "install" "Installs a list of packages." "" InstallCmd+data ListFlags = ListFlags {+ listInstalled :: Flag Bool,+ listSimpleOutput :: Flag Bool,+ listVerbosity :: Flag Verbosity+ } -listCmd :: Cmd-listCmd = mkCmd "list" "List available packages on the server." "" ListCmd+defaultListFlags :: ListFlags+defaultListFlags = ListFlags {+ listInstalled = Flag False,+ listSimpleOutput = Flag False,+ listVerbosity = toFlag normal+ } -updateCmd :: Cmd-updateCmd = mkCmd "update" "Updates list of known packages" "" UpdateCmd+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 }) -cleanCmd :: Cmd-cleanCmd = mkCmd "clean" "Removes downloaded files" "" CleanCmd+ , option [] ["installed"]+ "Only print installed packages"+ listInstalled (\v flags -> flags { listInstalled = v })+ trueArg -infoCmd :: Cmd-infoCmd = mkCmd "info" "Emit some info"- "Emits information about dependency resolution" InfoCmd+ , option [] ["simple-output"]+ "Print in a easy-to-parse format"+ listSimpleOutput (\v flags -> flags { listSimpleOutput = v })+ trueArg -parsePackageArgs :: Action -> [String] -> IO ([String],[UnresolvedDependency])-parsePackageArgs _ args- = return (globalArgs,parsePkgArgs pkgs)- where (globalArgs,pkgs) = break (not.(==)'-'.head) args- parseDep dep- = case readPToMaybe parseDependencyOrPackageId dep of- Nothing -> error ("Failed to parse package dependency: " ++ show dep)- Just x -> x- parsePkgArgs [] = []- parsePkgArgs (x:xs)- = let (args',rest) = break (not.(==) '-'.head) xs- in (UnresolvedDependency- { dependency = parseDep x- , depOptions = args' }- ):parsePkgArgs rest+ ]+ } +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 view
@@ -0,0 +1,300 @@+-----------------------------------------------------------------------------+-- |+-- 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 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 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 view
@@ -1,29 +1,58 @@--- | Simplistic TAR archive reading. Only gets the file names and file contents.-module Hackage.Tar (TarHeader(..), TarFileType(..),- readTarArchive, extractTarArchive, - extractTarGzFile, gunzip) where+-----------------------------------------------------------------------------+-- |+-- 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.Char8 as BS-import Data.ByteString.Lazy.Char8 (ByteString)-import Data.Bits ((.&.))+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)+import Data.List (unfoldr,partition,foldl') import Data.Maybe (catMaybes)-import Numeric (readOct)-import System.Directory (Permissions(..), setPermissions, createDirectoryIfMissing, copyFile)-import System.FilePath ((</>), isValid, isAbsolute)+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 Codec.Compression.GZip (decompress)+import qualified Codec.Compression.GZip as GZip+ ( decompress, compress ) -- Or use Ian's gunzip: -- import Codec.Compression.GZip.GUnZip (gunzip) -gunzip :: ByteString -> ByteString-gunzip = decompress- data TarHeader = TarHeader { tarFileName :: FilePath, tarFileMode :: FileMode,@@ -41,24 +70,34 @@ readTarArchive :: ByteString -> [(TarHeader,ByteString)] readTarArchive = catMaybes . unfoldr getTarEntry -extractTarArchive :: Maybe FilePath -> [(TarHeader,ByteString)] -> IO ()-extractTarArchive mdir = mapM_ (uncurry (extractEntry mdir))+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 :: Maybe FilePath -- ^ Destination directory- -> FilePath -- ^ Tarball- -> IO ()-extractTarGzFile mdir file = - BS.readFile file >>= extractTarArchive mdir . readTarArchive . decompress {- gunzip -}+extractTarGzFile :: FilePath -- ^ Destination directory+ -> FilePath -- ^ Tarball+ -> IO ()+extractTarGzFile dir file =+ extractTarArchive dir . readTarArchive . GZip.decompress =<< BS.readFile file -- -- * Extracting -- -extractEntry :: Maybe FilePath -> TarHeader -> ByteString -> IO ()-extractEntry mdir hdr cnt- = do path <- relativizePath mdir (tarFileName hdr)+extractEntry :: FilePath -> TarHeader -> ByteString -> IO ()+extractEntry dir hdr cnt+ = do path <- relativizePath dir (tarFileName hdr) let setPerms = setPermissions path (fileModeToPermissions (tarFileMode hdr))- copyLinked = relativizePath mdir (tarLinkTarget hdr) >>= copyFile path+ 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@@ -66,11 +105,11 @@ TarDirectory -> createDirectoryIfMissing False path >> setPerms TarOther _ -> return () -- FIXME: warning? -relativizePath :: Monad m => Maybe FilePath -> FilePath -> m FilePath-relativizePath mdir file+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 $ maybe file (</> file) mdir+ | otherwise = return $ dir </> file fileModeToPermissions :: FileMode -> Permissions fileModeToPermissions m = @@ -134,11 +173,11 @@ checkChkSum hdr s = s == chkSum hdr' || s == signedChkSum hdr' where -- replace the checksum with spaces- hdr' = BS.concat [BS.take 148 hdr, BS.replicate 8 ' ', BS.drop 156 hdr]+ 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.foldl' (\x y -> x + ord y) 0- signedChkSum = BS.foldl' (\x y -> x + (ordSigned y)) 0+ 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)@@ -156,7 +195,191 @@ getBytes off len = BS.take len . BS.drop off getByte :: Int64 -> ByteString -> Char-getByte off bs = BS.index bs off+getByte off bs = BS.Char8.index bs off getString :: Int64 -> Int64 -> ByteString -> String-getString off len = BS.unpack . BS.takeWhile (/='\0') . getBytes off len+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 view
@@ -12,83 +12,96 @@ ----------------------------------------------------------------------------- module Hackage.Types where -import Distribution.Simple.Compiler (CompilerFlavor)-import Distribution.Simple.InstallDirs (InstallDirTemplates)-import Distribution.Package (PackageIdentifier)-import Distribution.PackageDescription (GenericPackageDescription)-import Distribution.Version (Dependency)-import Distribution.Verbosity+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 URL.-data PkgInfo = PkgInfo {- pkgInfoId :: PackageIdentifier,- pkgRepo :: Repo,- pkgDesc :: GenericPackageDescription- }- deriving (Show)+-- field to store the tarball URI.+data AvailablePackage = AvailablePackage {+ packageInfoId :: PackageIdentifier,+ packageDescription :: GenericPackageDescription,+ packageSource :: AvailablePackageSource+ }+ deriving Show -data Action- = FetchCmd- | InstallCmd- | CleanCmd- | UpdateCmd- | InfoCmd- | HelpCmd- | ListCmd- deriving (Show,Eq)+instance Package AvailablePackage where packageId = packageInfoId -data Option = OptCompilerFlavor CompilerFlavor- | OptCompiler FilePath- | OptHcPkg FilePath- | OptConfigFile FilePath- | OptCacheDir FilePath- | OptPrefix FilePath- | OptBinDir FilePath- | OptLibDir FilePath- | OptLibSubDir FilePath- | OptLibExecDir FilePath- | OptDataDir FilePath- | OptDataSubDir FilePath- | OptDocDir FilePath- | OptHtmlDir FilePath- | OptUserInstall Bool- | OptHelp- | OptVerbose Verbosity- deriving (Eq,Show)+data AvailablePackageSource = -data ConfigFlags = ConfigFlags {- configCompiler :: CompilerFlavor,- configCompilerPath :: Maybe FilePath,- configHcPkgPath :: Maybe FilePath,- configUserInstallDirs :: InstallDirTemplates,- configGlobalInstallDirs :: InstallDirTemplates,- configCacheDir :: FilePath,- configRepos :: [Repo], -- ^Available Hackage servers.- configVerbose :: Verbosity,- configUserInstall :: Bool -- ^--user-install flag- }- deriving (Show)+ -- | 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 {- repoName :: String,- repoURL :: String- }- deriving (Show,Eq)+ repoRemote :: RemoteRepo,+ repoCacheDir :: FilePath+ }+ deriving (Show,Eq) -data ResolvedPackage = Installed Dependency PackageIdentifier- | Available Dependency PkgInfo [String] [ResolvedPackage]- | Unavailable Dependency- deriving (Show)+repoName :: Repo -> String+repoName = remoteRepoName . repoRemote -fulfills :: ResolvedPackage -> Dependency-fulfills (Installed d _) = d-fulfills (Available d _ _ _) = d-fulfills (Unavailable d) = d+repoURI :: Repo -> URI+repoURI = remoteRepoURI . repoRemote data UnresolvedDependency = UnresolvedDependency { dependency :: Dependency- , depOptions :: [String]+ , depFlags :: FlagAssignment } deriving (Show)++data BuildResult = DependentFailed PackageIdentifier+ | UnpackFailed Exception+ | ConfigureFailed Exception+ | BuildFailed Exception+ | InstallFailed Exception+ | BuildOk
Hackage/Update.hs view
@@ -16,20 +16,22 @@ import Hackage.Types import Hackage.Fetch-import Hackage.Tar -import qualified Data.ByteString.Lazy.Char8 as BS+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)-import Text.Printf -- | 'update' downloads the package list from all known servers-update :: ConfigFlags -> IO ()-update cfg = mapM_ (updateRepo cfg) (configRepos cfg)+update :: Verbosity -> [Repo] -> IO ()+update verbosity = mapM_ (updateRepo verbosity) -updateRepo :: ConfigFlags - -> Repo- -> IO ()-updateRepo cfg repo =- do printf "Downloading package list from server '%s'\n" (repoURL repo)- indexPath <- downloadIndex cfg repo- BS.readFile indexPath >>= BS.writeFile (dropExtension indexPath) . gunzip+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 view
@@ -0,0 +1,137 @@+-- 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 view
@@ -1,98 +1,55 @@ module Hackage.Utils where -import Distribution.Compat.ReadP (ReadP, readP_to_S, pfail, get, look, choice, (+++))-import Distribution.Package (PackageIdentifier(..), parsePackageId)-import Distribution.ParseUtils - (Field(..), FieldDescr(..), ParseResult(..), PError- , field, liftField, readFields- , showDependency, parseDependency- , warning, lineNo, locatedErrorMsg)-import Distribution.Version (Version(..), Dependency(..), VersionRange(..))+import Distribution.Package+ ( Dependency(..) )+import Distribution.Text+ ( display )+import Distribution.Simple.Utils (intercalate) -import Control.Exception-import Control.Monad (foldM, liftM, guard)-import Data.Char (isSpace, toLower)-import Data.List (intersperse)-import Data.Maybe (listToMaybe)+import Data.List+ ( sortBy, groupBy )+import Control.Monad (guard)+import Control.Exception (Exception, catchJust, ioErrors) import System.IO.Error (isDoesNotExistError)-import Text.PrettyPrint.HughesPJ (Doc, render, vcat, text, (<>), (<+>)) - readFileIfExists :: FilePath -> IO (Maybe String)-readFileIfExists path = +readFileIfExists path = catchJust fileNotFoundExceptions - (fmap Just (readFile path)) + (fmap Just (readFile path)) (\_ -> return Nothing) fileNotFoundExceptions :: Exception -> Maybe IOError fileNotFoundExceptions e = ioErrors e >>= \ioe -> guard (isDoesNotExistError ioe) >> return ioe --showPError :: PError -> String-showPError err = let (ml,msg) = locatedErrorMsg err- in maybe "" (\l -> "On line " ++ show l ++ ": ") ml ++ msg----readPToMaybe :: ReadP r 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]+showDependencies :: [Dependency] -> String+showDependencies = intercalate ", " . map display -boolField :: String -> (a -> Bool) -> (Bool -> a -> a) -> FieldDescr a-boolField name g s = liftField g s $ field name showBool readBool+-- | 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- 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+ 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 -showDependencies :: [Dependency] -> String-showDependencies = concat . intersperse ", " . map (show . showDependency)+duplicates :: Ord a => [a] -> [[a]]+duplicates = duplicatesBy compare -parseDependencyOrPackageId :: ReadP r Dependency-parseDependencyOrPackageId = parseDependency +++ liftM pkgToDep parsePackageId- where pkgToDep p = case pkgVersion p of- Version [] _ -> Dependency (pkgName p) AnyVersion- version -> Dependency (pkgName p) (ThisVersion version)+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
LICENSE view
@@ -1,7 +1,8 @@-Copyright (c) 2003-2007, Isaac Jones, Simon Marlow, Martin Sjögren,+Copyright (c) 2003-2008, Isaac Jones, Simon Marlow, Martin Sjögren, Bjorn Bringert, Krasimir Angelov, Malcolm Wallace, Ross Patterson,- Lemmih, Paolo Martini, Don Stewart+ Lemmih, Paolo Martini, Don Stewart,+ Duncan Coutts All rights reserved. Redistribution and use in source and binary forms, with or without
Main.hs view
@@ -13,48 +13,252 @@ module Main where -import Hackage.Types (Action (..), Option(..))-import Hackage.Setup (parseGlobalArgs, parsePackageArgs, configFromOptions)-import Hackage.Config (defaultConfigFile, loadConfig, findCompiler- , message, showConfig)+import Hackage.Setup+import Hackage.Types+ ( UnresolvedDependency(UnresolvedDependency) )+import Distribution.Simple.Setup (Flag(..), fromFlag, fromFlagOrDefault,+ flagToMaybe,SDistFlags,sdistCommand)+import qualified Distribution.Simple.Setup as Cabal+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)-import Hackage.Info (info)+import Hackage.Install (install, upgrade) import Hackage.Update (update) import Hackage.Fetch (fetch)-import Hackage.Clean (clean)+import Hackage.Check as Check (check)+--import Hackage.Clean (clean)+import Hackage.Upload as Upload (upload, check)+import Hackage.SrcDist(sdist) -import Distribution.Verbosity (verbose)+import Distribution.Verbosity (Verbosity, normal)+import qualified Paths_cabal_install (version) -import System.Environment (getArgs)+import System.Environment (getArgs, getProgName)+import System.Exit (exitFailure)+import System.FilePath (splitExtension, takeExtension)+import System.Directory (doesFileExist)+import Data.List (intersperse)+import Data.Monoid (Monoid(..))+import Control.Monad (unless) -- | Entry point -- main :: IO ()-main = do- rawArgs <- getArgs- (action, flags, args) <- parseGlobalArgs rawArgs- configFile <- case [f | OptConfigFile f <- flags] of- [] -> defaultConfigFile- fs -> return (last fs)+main = getArgs >>= mainWorker - conf0 <- loadConfig configFile+mainWorker :: [String] -> IO ()+mainWorker args = + case commandsRun globalCommand commands args of+ CommandHelp help -> printHelp help+ CommandList opts -> printOptionsList opts+ CommandErrors errs -> printErrors errs+ CommandReadyToGo (flags, commandParse) ->+ case commandParse of+ _ | fromFlag (globalVersion flags) -> printVersion+ | fromFlag (globalNumericVersion flags) -> printNumericVersion+ CommandHelp help -> printHelp help+ CommandList opts -> printOptionsList opts+ CommandErrors errs -> printErrors errs+ CommandReadyToGo action -> action - let config = configFromOptions conf0 flags+ where+ printHelp help = getProgName >>= putStr . help+ printOptionsList = putStr . unlines+ printErrors errs = do+ putStr (concat (intersperse "\n" errs))+ exitFailure+ printNumericVersion = putStrLn $ display Paths_cabal_install.version+ printVersion = putStrLn $ "cabal-install version "+ ++ display Paths_cabal_install.version+ ++ "\nusing version "+ ++ display cabalVersion+ ++ " of the Cabal library " - message config verbose "Configuration:"- message config verbose (showConfig config)+ commands =+ [configureCommand `commandAddAction` configureAction+ ,installCommand `commandAddAction` installAction+ ,listCommand `commandAddAction` listAction+ ,updateCommand `commandAddAction` updateAction+ ,upgradeCommand `commandAddAction` upgradeAction+ ,fetchCommand `commandAddAction` fetchAction+ ,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+ ] - let runCmd f = do (globalArgs, pkgs) <- parsePackageArgs action args- (comp, conf) <- findCompiler config- f config comp conf globalArgs pkgs+wrapperAction :: Monoid flags+ => CommandUI flags+ -> (flags -> Flag Verbosity)+ -> (flags -> Flag String)+ -> Command (IO ())+wrapperAction command verbosityFlag distPrefFlag =+ commandAddAction command $ \flags extraArgs -> do+ let verbosity = fromFlagOrDefault normal (verbosityFlag flags)+ setupScriptOptions = defaultSetupScriptOptions {+ useDistPref = fromFlagOrDefault+ (useDistPref defaultSetupScriptOptions)+ (distPrefFlag flags)+ }+ setupWrapper verbosity setupScriptOptions Nothing+ command (const flags) extraArgs - case action of- InstallCmd -> runCmd install- InfoCmd -> runCmd info- ListCmd -> list config args- UpdateCmd -> update config- CleanCmd -> clean config- FetchCmd -> runCmd fetch- _ -> error "Unhandled command."+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+ (comp, conf) <- configCompilerAux flags'+ let setupScriptOptions = defaultSetupScriptOptions {+ useCompiler = Just comp,+ useProgramConfig = conf,+ useDistPref = fromFlagOrDefault+ (useDistPref defaultSetupScriptOptions)+ (Cabal.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)+ in setupWrapper verbosity defaultSetupScriptOptions Nothing+ Cabal.installCommand mempty []++installAction (cflags,iflags) extraArgs = 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+ (comp, conf) <- configCompilerAux cflags'+ install verbosity+ (configPackageDB cflags') (configRepos config)+ comp conf cflags' iflags+ [ UnresolvedDependency pkg (Cabal.configConfigurationsFlags cflags')+ | pkg <- pkgs ]++listAction :: ListFlags -> [String] -> IO ()+listAction listFlags extraArgs = do+ configFile <- defaultConfigFile --FIXME+ let verbosity = fromFlag (listVerbosity listFlags)+ config <- loadConfig verbosity configFile+ let flags = savedConfigToConfigFlags NoFlag config+ (comp, conf) <- configCompilerAux flags+ list verbosity+ (configPackageDB flags)+ (configRepos config)+ comp+ conf+ listFlags+ extraArgs++updateAction :: Flag Verbosity -> [String] -> IO ()+updateAction verbosityFlag _extraArgs = do+ configFile <- defaultConfigFile --FIXME+ let verbosity = fromFlag verbosityFlag+ config <- loadConfig verbosity configFile+ update verbosity (configRepos config)++upgradeAction :: (Cabal.ConfigFlags, InstallFlags) -> [String] -> IO ()+upgradeAction (cflags,iflags) extraArgs = 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+ (comp, conf) <- configCompilerAux cflags'+ upgrade verbosity+ (configPackageDB cflags') (configRepos config)+ comp conf cflags' iflags+ [ UnresolvedDependency pkg (Cabal.configConfigurationsFlags cflags')+ | pkg <- pkgs ]++fetchAction :: Flag Verbosity -> [String] -> IO ()+fetchAction verbosityFlag extraArgs = do+ pkgs <- either die return (parsePackageArgs extraArgs)+ configFile <- defaultConfigFile --FIXME+ let verbosity = fromFlag verbosityFlag+ config <- loadConfig verbosity configFile+ let flags = savedConfigToConfigFlags NoFlag config+ (comp, conf) <- configCompilerAux flags+ fetch verbosity+ (configPackageDB flags) (configRepos 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+ -- FIXME: check that the .tar.gz files exist and report friendly error message if not+ let tarfiles = extraArgs+ checkTarFiles tarfiles+ if fromFlag (uploadCheck flags)+ then Upload.check verbosity tarfiles+ else upload verbosity + (flagToMaybe $ configUploadUsername config+ `mappend` uploadUsername flags)+ (flagToMaybe $ configUploadPassword config+ `mappend` uploadPassword flags)+ tarfiles+ where+ checkTarFiles tarfiles+ | null tarfiles+ = die "the 'upload' command expects one or more .tar.gz packages."+ | not (null otherFiles)+ = die $ "the 'upload' command expects only .tar.gz packages: "+ ++ intercalate ", " otherFiles+ | otherwise = sequence_+ [ do exists <- doesFileExist tarfile+ unless exists $ die $ "file not found: " ++ tarfile+ | tarfile <- tarfiles ]++ where otherFiles = filter (not . isTarGzFile) tarfiles+ isTarGzFile file = case splitExtension file of+ (file', ".gz") -> takeExtension file' == ".tar"+ _ -> False++checkAction :: Flag Verbosity -> [String] -> IO ()+checkAction verbosityFlag extraArgs = 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+ unless (null extraArgs) $ do+ die $ "'sdist' doesn't take any extra arguments: " ++ unwords extraArgs+ sdist sflags
README view
@@ -4,44 +4,35 @@ Intended usage: - cabal install xmonad+ cabal install xmonad -Just works. Defaults make sense, and by default we don't fail unless it-is unrecoverable.+Just works. Defaults make sense. -== Dependences ==+It also has all the other commands that runhaskell Setup.hs supports. Eg - base >= 2.1, process, directory, pretty, bytestring >= 0.9- mtl, network, regex-compat, unix, Cabal>=1.3,- zlib >= 0.4, HTTP >= 3000.0 && < 3000.1, filepath >= 1.0+ cabal configure+ cabal build+ cabal install+ cabal haddock+ cabal sdist+ cabal clean -Kind of ironic we need cabal install to make it easier to build cabal-install. +See cabal --help for the full list. -== Developer docs ==+There are also these extra commands: - CabalInstall, what happens under the hood.+ cabal update Updates the packages list from the hackage server+ cabal list [pkgs] List packages with the given search terms in their name+ cabal upgrade [pkgs] Like install but also upgrade all dependencies+ cabal upgrade Upgrade all installed packages+ cabal upload [tar] Upload a package tarball to the hackage server+ cabal check Check the package for common mistakes - FetchCmd:- cabal-install stores packages in [config-dir]/packages/ by their package id.- This can lead to clashes if there's two identical (same name, same version)- packages from two servers with different functionality.- CleanCmd:- Removes all fetched packages.- UpdateCmd:- Queries all known servers for their packages and stores it in [cfg-dir]/pkg.list.- InstallCmd:- Installed packages are determined, and dependencies of the to-be-installed packages- are resolved and fetched.- The fetched tarballs are moved to a temporary directory (usually /tmp) and extracted.- Distribution.Simple.SetupWrapper is used to configure, build and install the- unpacked package. The user can- only pass arguments to the 'configure' phase of the installation. '--user' is used- by default.- InfoCmd:- To be written.+== Dependences == - Files used by cabal-install:- [cfg-dir]/config configuration file- [cfg-dir]/00-index.tar list of packages available from the servers.- [cfg-dir]/packages/ directory containing all fetched packages.+Dependencies on standard libs:+ base >= 2.1, process, directory, pretty, bytestring >= 0.9+ network, filepath >= 1.0, Cabal >=1.3.11 && <1.5++Dependencies on other libs:+ zlib >= 0.4, HTTP >= 3000.0 && < 3001.2
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
− Setup.lhs
@@ -1,3 +0,0 @@-#!/usr/bin/env runhaskell-> import Distribution.Simple-> main = defaultMain
+ bash-completion/cabal view
@@ -0,0 +1,131 @@+# cabal command line completion+# Copyright 2007-2008 "Lennart Kolmodin" <kolmodin@gentoo.org>+# "Duncan Coutts" <dcoutts@gentoo.org>+#++# returns packages from cabal list+# usage: _cabal_packages [packages] [versions] [installed]+_cabal_packages()+{+ local packages=no # print package names with versions? ie. foo+ local versions=no # print packages and versions? ie. foo-0.42+ local installed=no # only print installed packages?++ while [[ -n "$1" ]]; do+ case "$1" in+ packages)+ packages=yes ;;+ versions)+ versions=yes ;;+ installed)+ installed=yes ;;+ esac+ shift+ done++ if [[ "$packages" == "no" && "$versions" == "no" ]]; then+ # nothing to print+ # set sensible default, print only packages+ packages=yes+ fi++ local cmd="cabal list --simple-output"+ if [[ "$installed" == "yes" ]]; then+ cmd="$cmd --installed"+ fi++ # save 'cabal list' output to a temporary file+ # putting it in a variable would mess up the lines+ local tmp=$( mktemp /tmp/cabal_completion.XXXXXX )+ $cmd > $tmp++ if [[ "$packages" == "yes" ]]; then+ # print only the names+ cat "$tmp" | cut -d' ' -f1 | uniq+ fi++ if [[ "$versions" == "yes" ]]; then+ # join the name and the version with a dash+ cat "$tmp" | sed -e "s: :-:"+ fi++ rm -f "$tmp"+}++_cabal_commands()+{+ # this is already quite fast, and caching does not give a speedup+ # 3-4ms+ for word in $( cabal --list-options ); do+ case $word in+ -*)+ # ignore flags+ continue;;+ *)+ echo $word ;;+ esac+ done+}++_cabal()+{+ # get the word currently being completed+ local cur+ cur=${COMP_WORDS[$COMP_CWORD]}++ # create a command line to run+ local cmd+ # copy all words the user has entered+ cmd=( ${COMP_WORDS[@]} )++ # the word currently beeing completed+ local ccword+ ccword=cmd[${COMP_CWORD}]++ # replace the current word with --list-options+ cmd[${COMP_CWORD}]="--list-options"++ # find the action being completed+ local action="unknown"+ for cword in ${COMP_WORDS[*]}; do+ for act in $( _cabal_commands ); do+ if [[ "$cword" == "$act" ]]; then+ action=$act+ fi+ done+ done++ # if non empty, we will pass this to _cabal_packages and add the result+ # to the completing words+ local complete_packages+ for cword in ${COMP_WORDS[*]}; do+ case $cword in+ --installed)+ # the user is interested only in installed packages+ complete_packages="$complete_packages installed"+ esac+ done++ case $action in+ install|list|upgrade|fetch)+ if [[ "$cword" != -* ]]; then+ # don't complete with packages if the user is trying to+ # complete a flag+ complete_packages="$complete_packages packages"+ if [[ "$cword" == *- ]]; then+ # if the user tries to complete with a version, help by+ # completing them too+ complete_packages="$complete_packages versions"+ fi+ fi ;;+ esac++ # the resulting completions should be put into this array+ COMPREPLY=( $( compgen -W "$( ${cmd[@]} )" -- $cur ) )++ if [[ -n "$complete_packages" ]]; then+ COMPREPLY+=( $( compgen -W "$( _cabal_packages $complete_packages )" -- $cur ) )+ fi+}++complete -F _cabal -o default cabal
cabal-install.cabal view
@@ -1,20 +1,27 @@ Name: cabal-install-Version: 0.4.0-Synopsis: Automatic package handling for Haskell+Version: 0.5.0+Synopsis: The command-line interface for Cabal and Hackage. Description: - apt-get like tool for Haskell. 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.+ 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. License: BSD3 License-File: LICENSE-Author: Lemmih <lemmih@gmail.com>, Paolo Martini <paolo@nemail.it>+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> Maintainer: cabal-devel@haskell.org-Copyright: 2005 Lemmih <lemmih@gmail.com>, 2006 Paolo Martini <paolo@nemail.it>+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> Stability: Experimental Category: Distribution Build-type: Simple-Extra-Source-Files: README+Extra-Source-Files: README bash-completion/cabal Cabal-Version: >= 1.2 flag old-base@@ -25,31 +32,61 @@ Executable cabal Main-Is: Main.hs- Ghc-Options: -Wall+ -- We want assertion checking on even if people build with -O+ -- although it is expensive, we want to catch problems early:+ Ghc-Options: -Wall -fno-ignore-asserts Other-Modules:- Hackage.Clean+ 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.Index- Hackage.Info+ 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 - build-depends: Cabal >= 1.2, filepath >= 1.0, network,- zlib >= 0.3, HTTP >= 3000.0 && < 3001.1+ build-depends: Cabal >= 1.4 && < 1.5,+ filepath >= 1.0,+ network >= 1 && < 3,+ HTTP >= 3000 && < 3002,+ zlib >= 0.4 if flag(old-base) build-depends: base < 3 else- build-depends: base >= 3, process, directory, pretty+ build-depends: base >= 3 && < 4,+ process >= 1 && < 1.1,+ directory >= 1 && < 1.1,+ pretty >= 1 && < 1.1,+ random >= 1 && < 1.1,+ containers >= 0.1 && < 0.2,+ array >= 0.1 && < 0.2,+ old-time >= 1 && < 1.1 if flag(bytestring-in-base) build-depends: base >= 2.0 && < 2.2 else build-depends: base < 2.0 || >= 3.0, bytestring >= 0.9++ if os(windows)+ build-depends: Win32 >= 2 && < 3+ cpp-options: -DWIN32