diff --git a/Hackage/Check.hs b/Hackage/Check.hs new file mode 100644 --- /dev/null +++ b/Hackage/Check.hs @@ -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) diff --git a/Hackage/Clean.hs b/Hackage/Clean.hs deleted file mode 100644 --- a/Hackage/Clean.hs +++ /dev/null @@ -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 ())) diff --git a/Hackage/Config.hs b/Hackage/Config.hs --- a/Hackage/Config.hs +++ b/Hackage/Config.hs @@ -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 + } diff --git a/Hackage/Dependency.hs b/Hackage/Dependency.hs --- a/Hackage/Dependency.hs +++ b/Hackage/Dependency.hs @@ -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 ] diff --git a/Hackage/Dependency/Bogus.hs b/Hackage/Dependency/Bogus.hs new file mode 100644 --- /dev/null +++ b/Hackage/Dependency/Bogus.hs @@ -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)) diff --git a/Hackage/Dependency/Naive.hs b/Hackage/Dependency/Naive.hs new file mode 100644 --- /dev/null +++ b/Hackage/Dependency/Naive.hs @@ -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)) diff --git a/Hackage/Dependency/TopDown.hs b/Hackage/Dependency/TopDown.hs new file mode 100644 --- /dev/null +++ b/Hackage/Dependency/TopDown.hs @@ -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' diff --git a/Hackage/Dependency/TopDown/Constraints.hs b/Hackage/Dependency/TopDown/Constraints.hs new file mode 100644 --- /dev/null +++ b/Hackage/Dependency/TopDown/Constraints.hs @@ -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 ] diff --git a/Hackage/Dependency/TopDown/Types.hs b/Hackage/Dependency/TopDown/Types.hs new file mode 100644 --- /dev/null +++ b/Hackage/Dependency/TopDown/Types.hs @@ -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 diff --git a/Hackage/Dependency/Types.hs b/Hackage/Dependency/Types.hs new file mode 100644 --- /dev/null +++ b/Hackage/Dependency/Types.hs @@ -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 diff --git a/Hackage/Fetch.hs b/Hackage/Fetch.hs --- a/Hackage/Fetch.hs +++ b/Hackage/Fetch.hs @@ -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"] + } diff --git a/Hackage/HttpUtils.hs b/Hackage/HttpUtils.hs new file mode 100644 --- /dev/null +++ b/Hackage/HttpUtils.hs @@ -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) diff --git a/Hackage/Index.hs b/Hackage/Index.hs deleted file mode 100644 --- a/Hackage/Index.hs +++ /dev/null @@ -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 [] diff --git a/Hackage/IndexUtils.hs b/Hackage/IndexUtils.hs new file mode 100644 --- /dev/null +++ b/Hackage/IndexUtils.hs @@ -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 ] diff --git a/Hackage/Info.hs b/Hackage/Info.hs deleted file mode 100644 --- a/Hackage/Info.hs +++ /dev/null @@ -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" diff --git a/Hackage/Install.hs b/Hackage/Install.hs --- a/Hackage/Install.hs +++ b/Hackage/Install.hs @@ -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) diff --git a/Hackage/InstallPlan.hs b/Hackage/InstallPlan.hs new file mode 100644 --- /dev/null +++ b/Hackage/InstallPlan.hs @@ -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" diff --git a/Hackage/List.hs b/Hackage/List.hs --- a/Hackage/List.hs +++ b/Hackage/List.hs @@ -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) diff --git a/Hackage/ParseUtils.hs b/Hackage/ParseUtils.hs new file mode 100644 --- /dev/null +++ b/Hackage/ParseUtils.hs @@ -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) diff --git a/Hackage/Reporting.hs b/Hackage/Reporting.hs new file mode 100644 --- /dev/null +++ b/Hackage/Reporting.hs @@ -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 diff --git a/Hackage/Setup.hs b/Hackage/Setup.hs --- a/Hackage/Setup.hs +++ b/Hackage/Setup.hs @@ -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) diff --git a/Hackage/SetupWrapper.hs b/Hackage/SetupWrapper.hs new file mode 100644 --- /dev/null +++ b/Hackage/SetupWrapper.hs @@ -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 diff --git a/Hackage/SrcDist.hs b/Hackage/SrcDist.hs new file mode 100644 --- /dev/null +++ b/Hackage/SrcDist.hs @@ -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 diff --git a/Hackage/Tar.hs b/Hackage/Tar.hs --- a/Hackage/Tar.hs +++ b/Hackage/Tar.hs @@ -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' = [pathc | 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 diff --git a/Hackage/Types.hs b/Hackage/Types.hs --- a/Hackage/Types.hs +++ b/Hackage/Types.hs @@ -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 diff --git a/Hackage/Update.hs b/Hackage/Update.hs --- a/Hackage/Update.hs +++ b/Hackage/Update.hs @@ -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 diff --git a/Hackage/Upload.hs b/Hackage/Upload.hs new file mode 100644 --- /dev/null +++ b/Hackage/Upload.hs @@ -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" diff --git a/Hackage/Utils.hs b/Hackage/Utils.hs --- a/Hackage/Utils.hs +++ b/Hackage/Utils.hs @@ -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 diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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 diff --git a/Main.hs b/Main.hs --- a/Main.hs +++ b/Main.hs @@ -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 diff --git a/README b/README --- a/README +++ b/README @@ -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 diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/Setup.lhs b/Setup.lhs deleted file mode 100644 --- a/Setup.lhs +++ /dev/null @@ -1,3 +0,0 @@ -#!/usr/bin/env runhaskell -> import Distribution.Simple -> main = defaultMain diff --git a/bash-completion/cabal b/bash-completion/cabal new file mode 100644 --- /dev/null +++ b/bash-completion/cabal @@ -0,0 +1,131 @@ +# cabal command line completion +# Copyright 2007-2008 "Lennart Kolmodin" +# "Duncan Coutts" +# + +# returns packages from cabal list +# usage: _cabal_packages [packages] [versions] [installed] +_cabal_packages() +{ + local packages=no # print package names with versions? ie. foo + local versions=no # print packages and versions? ie. foo-0.42 + local installed=no # only print installed packages? + + while [[ -n "$1" ]]; do + case "$1" in + packages) + packages=yes ;; + versions) + versions=yes ;; + installed) + installed=yes ;; + esac + shift + done + + if [[ "$packages" == "no" && "$versions" == "no" ]]; then + # nothing to print + # set sensible default, print only packages + packages=yes + fi + + local cmd="cabal list --simple-output" + if [[ "$installed" == "yes" ]]; then + cmd="$cmd --installed" + fi + + # save 'cabal list' output to a temporary file + # putting it in a variable would mess up the lines + local tmp=$( mktemp /tmp/cabal_completion.XXXXXX ) + $cmd > $tmp + + if [[ "$packages" == "yes" ]]; then + # print only the names + cat "$tmp" | cut -d' ' -f1 | uniq + fi + + if [[ "$versions" == "yes" ]]; then + # join the name and the version with a dash + cat "$tmp" | sed -e "s: :-:" + fi + + rm -f "$tmp" +} + +_cabal_commands() +{ + # this is already quite fast, and caching does not give a speedup + # 3-4ms + for word in $( cabal --list-options ); do + case $word in + -*) + # ignore flags + continue;; + *) + echo $word ;; + esac + done +} + +_cabal() +{ + # get the word currently being completed + 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 diff --git a/cabal-install.cabal b/cabal-install.cabal --- a/cabal-install.cabal +++ b/cabal-install.cabal @@ -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 , Paolo Martini +Author: Lemmih + Paolo Martini + Bjorn Bringert + Isaac Potoczny-Jones + Duncan Coutts Maintainer: cabal-devel@haskell.org -Copyright: 2005 Lemmih , 2006 Paolo Martini +Copyright: 2005 Lemmih + 2006 Paolo Martini + 2007 Bjorn Bringert + 2007 Isaac Potoczny-Jones + 2008 Duncan Coutts 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