cabal-install 0.5.0 → 0.5.1
raw patch · 9 files changed
+165/−71 lines, 9 files
Files
- Hackage/Config.hs +18/−9
- Hackage/Dependency/Bogus.hs +60/−24
- Hackage/Fetch.hs +3/−3
- Hackage/HttpUtils.hs +60/−20
- Hackage/IndexUtils.hs +12/−2
- Hackage/Install.hs +6/−8
- Hackage/List.hs +2/−3
- Main.hs +3/−1
- cabal-install.cabal +1/−1
Hackage/Config.hs view
@@ -47,6 +47,8 @@ import qualified Distribution.Simple.Setup as ConfigFlags import qualified Distribution.Simple.Setup as Cabal import Distribution.Verbosity (Verbosity, normal)+import Distribution.System+ ( OS(Windows), buildOS ) import Hackage.Types ( RemoteRepo(..), Repo(..), Username(..), Password(..) )@@ -116,6 +118,13 @@ defaultCompiler :: CompilerFlavor defaultCompiler = fromMaybe GHC defaultCompilerFlavor +defaultUserInstall :: Bool+defaultUserInstall = case buildOS of+ -- We do global installs by default on Windows+ Windows -> False+ -- and per-user installs by default everywhere else+ _ -> True+ defaultUserInstallDirs :: IO (InstallDirs (Flag PathTemplate)) defaultUserInstallDirs = do userPrefix <- defaultCabalDir@@ -130,15 +139,15 @@ 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"- }+ return SavedConfig {+ configFlags = mempty {+ ConfigFlags.configHcFlavor = toFlag defaultCompiler+ , ConfigFlags.configVerbosity = toFlag normal+ , ConfigFlags.configUserInstall = toFlag defaultUserInstall+ , ConfigFlags.configInstallDirs = error+ "ConfigFlags.installDirs: avoid this field. Use UserInstallDirs \+ \ or GlobalInstallDirs instead"+ } , configUserInstallDirs = userInstallDirs , configGlobalInstallDirs = defaultGlobalInstallDirs , configCacheDir = toFlag cacheDir
Hackage/Dependency/Bogus.hs view
@@ -1,6 +1,6 @@ ----------------------------------------------------------------------------- -- |--- Module : Hackage.Dependency+-- Module : Hackage.Dependency.Bogus -- Copyright : (c) David Himmelstrup 2005, Bjorn Bringert 2007 -- Duncan Coutts 2008 -- License : BSD-like@@ -15,23 +15,30 @@ 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 qualified Hackage.InstallPlan as InstallPlan+ import Distribution.Package ( PackageIdentifier(..), Dependency(..), Package(..) )+import Distribution.PackageDescription+ ( GenericPackageDescription(..), CondTree(..), FlagAssignment ) import Distribution.PackageDescription.Configuration- ( finalizePackageDescription)-import Distribution.Simple.Utils (comparing)-import Hackage.Utils- ( showDependencies )+ ( finalizePackageDescription )+import qualified Distribution.Simple.PackageIndex as PackageIndex+import Distribution.Simple.PackageIndex (PackageIndex)+import Distribution.Version+ ( VersionRange(IntersectVersionRanges) )+import Distribution.Simple.Utils+ ( equating, comparing )+import Distribution.Text+ ( display ) -import Data.List (maximumBy)+import Data.List+ ( maximumBy, sortBy, groupBy ) -- | This resolver thinks that every package is already installed. --@@ -39,26 +46,59 @@ -- 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+bogusResolver os arch comp _ available _ = resolveFromAvailable []+ . combineDependencies where- resolveFromAvailable (UnresolvedDependency dep flags) =+ resolveFromAvailable chosen [] = Done chosen+ resolveFromAvailable chosen (UnresolvedDependency dep flags : deps) = case latestAvailableSatisfying available dep of- Nothing -> Right dep+ Nothing -> Fail ("Unresolved dependency: " ++ display 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.+ Right (_, flags') -> Step msg (resolveFromAvailable chosen' deps)+ where+ msg = "selecting " ++ display (packageId pkg)+ cpkg = fudgeChosenPackage apkg flags'+ chosen' = InstallPlan.Configured cpkg : chosen _ -> error "bogusResolver: impossible happened" where none :: Maybe (PackageIndex PackageIdentifier) none = Nothing +fudgeChosenPackage :: AvailablePackage -> FlagAssignment -> ConfiguredPackage+fudgeChosenPackage (AvailablePackage pkgid pkg source) flags =+ ConfiguredPackage (AvailablePackage pkgid (stripDependencies pkg) source)+ flags ([] :: [PackageIdentifier]) -- empty list of deps+ where+ -- | Pretend that a package has no dependencies. Go through the+ -- 'GenericPackageDescription' and strip them all out.+ --+ stripDependencies :: GenericPackageDescription -> GenericPackageDescription+ stripDependencies gpkg = gpkg {+ condLibrary = fmap stripDeps (condLibrary gpkg),+ condExecutables = [ (name, stripDeps tree)+ | (name, tree) <- condExecutables gpkg ]+ }+ stripDeps :: CondTree v [Dependency] a -> CondTree v [Dependency] a+ stripDeps = mapTreeConstrs (const [])++ mapTreeConstrs :: (c -> c) -> CondTree v c a -> CondTree v c a+ mapTreeConstrs f (CondNode a c ifs) = CondNode a (f c) (map g ifs)+ where+ g (cnd, t, me) = (cnd, mapTreeConstrs f t, fmap (mapTreeConstrs f) me)++combineDependencies :: [UnresolvedDependency] -> [UnresolvedDependency]+combineDependencies = map combineGroup+ . groupBy (equating depName)+ . sortBy (comparing depName)+ where+ combineGroup deps = UnresolvedDependency (Dependency name ver) flags+ where name = depName (head deps)+ ver = foldr1 IntersectVersionRanges . map depVer $ deps+ flags = concatMap depFlags deps+ depName (UnresolvedDependency (Dependency name _) _) = name+ depVer (UnresolvedDependency (Dependency _ ver) _) = ver+ -- | Gets the latest available package satisfying a dependency. latestAvailableSatisfying :: PackageIndex AvailablePackage -> Dependency@@ -67,7 +107,3 @@ case PackageIndex.lookupDependency index dep of [] -> Nothing pkgs -> Just (maximumBy (comparing (pkgVersion . packageId)) pkgs)--unzipEithers :: [Either a b] -> ([a], [b])-unzipEithers = foldr (flip consEither) ([], [])- where consEither ~(ls,rs) = either (\l -> (l:ls,rs)) (\r -> (ls,r:rs))
Hackage/Fetch.hs view
@@ -29,7 +29,8 @@ , AvailablePackageSource(..), Repo(..), repoURI ) import Hackage.Dependency ( resolveDependencies, PackagesVersionPreference(..) )-import qualified Hackage.IndexUtils as IndexUtils+import Hackage.IndexUtils as IndexUtils+ ( getAvailablePackages, disambiguateDependencies ) import qualified Hackage.InstallPlan as InstallPlan import Hackage.HttpUtils (getHTTP) @@ -47,7 +48,6 @@ ( display ) import Distribution.Verbosity (Verbosity) -import Data.Monoid (Monoid(mconcat)) import Control.Exception (bracket) import Control.Monad (filterM) import System.Directory (doesFileExist, createDirectoryIfMissing)@@ -125,7 +125,7 @@ -> IO () fetch verbosity packageDB repos comp conf deps = do installed <- getInstalledPackages verbosity comp packageDB conf- available <- fmap mconcat (mapM (IndexUtils.readRepoIndex verbosity) repos)+ available <- getAvailablePackages verbosity repos deps' <- IndexUtils.disambiguateDependencies available deps case resolveDependencies buildOS buildArch (compilerId comp) installed available PreferLatestForSelected deps' of
Hackage/HttpUtils.hs view
@@ -4,17 +4,29 @@ ----------------------------------------------------------------------------- module Hackage.HttpUtils (getHTTP, proxy) where -import Network.HTTP (Request (..), Response (..), RequestMethod (..), Header(..), HeaderName(..))-import Network.URI (URI (..), URIAuth (..), parseURI)+import Network.HTTP+ ( Request (..), Response (..), RequestMethod (..)+ , Header(..), HeaderName(..) )+import Network.URI+ ( URI (..), URIAuth (..), parseAbsoluteURI ) import Network.Stream (Result) import Network.Browser (Proxy (..), Authority (..), browse, setOutHandler, setErrHandler, setProxy, request)-import Control.Monad (mplus)+import Control.Monad+ ( mplus, join ) #ifdef WIN32-import System.Win32.Registry (hKEY_CURRENT_USER, regOpenKey, regQueryValue, regCloseKey)-import Control.Exception (try, bracket)-#endif+import System.Win32.Types+ ( DWORD, HKEY )+import System.Win32.Registry+ ( hKEY_CURRENT_USER, regOpenKey, regCloseKey+ , regQueryValue, regQueryValueEx )+import Control.Exception+ ( handle, bracket )+import Foreign+ ( toBool, Storable(peek, sizeOf), castPtr, alloca )+#else import System.Environment (getEnvironment)+#endif import qualified Paths_cabal_install (version) import Distribution.Verbosity (Verbosity)@@ -22,13 +34,20 @@ import Distribution.Text ( display ) +-- FIXME: all this proxy stuff is far too complicated, especially parsing+-- the proxy strings. Network.Browser should have a way to pick up the+-- proxy settings hiding all this system-dependent stuff below.+ -- try to read the system proxy settings on windows or unix proxyString :: IO (Maybe String) #ifdef WIN32 -- read proxy settings from the windows registry-proxyString = fmap (either (const Nothing) Just) $ try $- bracket (regOpenKey hive path) regCloseKey- (\hkey -> regQueryValue hkey (Just "ProxyServer"))+proxyString = handle (\_ -> return Nothing) $+ bracket (regOpenKey hive path) regCloseKey $ \hkey -> do+ enable <- fmap toBool $ regQueryValueDWORD hkey "ProxyEnable"+ if enable+ then fmap Just $ regQueryValue hkey (Just "ProxyServer")+ else return Nothing where -- some sources say proxy settings should be at -- HKEY_LOCAL_MACHINE\SOFTWARE\Policies\Microsoft\Windows@@ -37,6 +56,11 @@ -- end up in the following place: hive = hKEY_CURRENT_USER path = "Software\\Microsoft\\Windows\\CurrentVersion\\Internet Settings"++ regQueryValueDWORD :: HKEY -> String -> IO DWORD+ regQueryValueDWORD hkey name = alloca $ \ptr -> do+ regQueryValueEx hkey name (castPtr ptr) (sizeOf (undefined :: DWORD))+ peek ptr #else -- read proxy settings by looking for an env var proxyString = do@@ -49,17 +73,33 @@ 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+ Nothing -> return NoProxy+ Just str -> case parseHttpProxy str of+ Nothing -> do+ warn verbosity $ "invalid http proxy uri: " ++ show str+ warn verbosity $ "proxy uri must be http with a hostname"+ warn verbosity $ "ignoring http proxy, trying a direct connection"+ return NoProxy+ Just p -> return p++-- | We need to be able to parse non-URIs like @\"wwwcache.example.com:80\"@+-- which lack the @\"http://\"@ URI scheme. The problem is that+-- @\"wwwcache.example.com:80\"@ is in fact a valid URI but with scheme+-- @\"wwwcache.example.com:\"@, no authority part and a path of @\"80\"@.+--+-- So our strategy is to try parsing as normal uri first and if it lacks the+-- 'uriAuthority' then we try parsing again with a @\"http://\"@ prefix.+--+parseHttpProxy :: String -> Maybe Proxy+parseHttpProxy str = join+ . fmap uri2proxy+ $ parseHttpURI str+ `mplus` parseHttpURI ("http://" ++ str)+ where+ parseHttpURI str' = case parseAbsoluteURI str' of+ Just uri@URI { uriAuthority = Just _ }+ -> Just uri+ _ -> Nothing uri2proxy :: URI -> Maybe Proxy uri2proxy uri@URI{ uriScheme = "http:"
Hackage/IndexUtils.hs view
@@ -11,6 +11,7 @@ -- Extra utils related to the package indexes. ----------------------------------------------------------------------------- module Hackage.IndexUtils (+ getAvailablePackages, readRepoIndex, disambiguatePackageName, disambiguateDependencies@@ -31,15 +32,24 @@ import Distribution.Text ( simpleParse ) import Distribution.Verbosity (Verbosity)-import Distribution.Simple.Utils (die, warn, intercalate, fromUTF8)+import Distribution.Simple.Utils (die, warn, info, intercalate, fromUTF8) import Prelude hiding (catch)-import Control.Exception (catch, Exception(IOException))+import Data.Monoid (Monoid(mconcat))+import Control.Exception (evaluate, catch, Exception(IOException)) import qualified Data.ByteString.Lazy as BS import qualified Data.ByteString.Lazy.Char8 as BS.Char8 import Data.ByteString.Lazy (ByteString) import System.FilePath ((</>), takeExtension, splitDirectories, normalise) import System.IO.Error (isDoesNotExistError)+++getAvailablePackages :: Verbosity -> [Repo]+ -> IO (PackageIndex AvailablePackage)+getAvailablePackages verbosity repos = do+ info verbosity "Reading available packages..."+ pkgss <- mapM (readRepoIndex verbosity) repos+ evaluate (mconcat pkgss) -- | Read a repository index from disk, from the local file specified by -- the 'Repo'.
Hackage/Install.hs view
@@ -17,7 +17,6 @@ import Data.List ( unfoldr )-import Data.Monoid (Monoid(mconcat)) import Control.Exception as Exception ( handle, Exception ) import Control.Monad@@ -32,7 +31,8 @@ import Hackage.Dependency.Types (Progress(..), foldProgress) import Hackage.Fetch (fetchPackage) -- import qualified Hackage.Info as Info-import qualified Hackage.IndexUtils as IndexUtils+import Hackage.IndexUtils as IndexUtils+ ( getAvailablePackages, disambiguateDependencies ) import qualified Hackage.InstallPlan as InstallPlan import Hackage.InstallPlan (InstallPlan) import Hackage.Setup@@ -60,7 +60,7 @@ import Distribution.Simple.Utils ( defaultPackageDesc, inDir, rawSystemExit, withTempDirectory ) import Distribution.Package- ( PackageIdentifier(..), Package(..), Dependency(..) )+ ( PackageIdentifier(..), Package(..), thisPackageVersion ) import Distribution.PackageDescription as PackageDescription ( GenericPackageDescription(packageDescription) , readPackageDescription )@@ -125,7 +125,7 @@ -> 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)+ available <- getAvailablePackages verbosity repos progress <- planner installed available @@ -184,8 +184,7 @@ packageSource = LocalUnpackedPackage } localPkgDep = UnresolvedDependency {- dependency = let PackageIdentifier n v = packageId localPkg- in Dependency n (ThisVersion v),+ dependency = thisPackageVersion (packageId localPkg), depFlags = Cabal.configConfigurationsFlags configFlags } @@ -278,8 +277,7 @@ installConfiguredPackage configFlags (ConfiguredPackage pkg flags deps) installPkg = installPkg configFlags { Cabal.configConfigurationsFlags = flags,- Cabal.configConstraints = [ Dependency name (ThisVersion version)- | PackageIdentifier name version <- deps ]+ Cabal.configConstraints = map thisPackageVersion deps } pkg installAvailablePackage
Hackage/List.hs view
@@ -16,7 +16,6 @@ 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) @@ -33,7 +32,7 @@ import Distribution.Version (Version) import Distribution.Verbosity (Verbosity) -import qualified Hackage.IndexUtils as IndexUtils (readRepoIndex)+import Hackage.IndexUtils (getAvailablePackages) import Hackage.Setup (ListFlags(..)) import Hackage.Types (AvailablePackage(..), Repo) import Distribution.Simple.Configure (getInstalledPackages)@@ -55,7 +54,7 @@ -> 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)+ available <- getAvailablePackages verbosity repos let pkgs | null pats = (PackageIndex.allPackages installed ,PackageIndex.allPackages available) | otherwise =
Main.hs view
@@ -181,7 +181,9 @@ extraArgs updateAction :: Flag Verbosity -> [String] -> IO ()-updateAction verbosityFlag _extraArgs = do+updateAction verbosityFlag extraArgs = do+ unless (null extraArgs) $ do+ die $ "'update' doesn't take any extra arguments: " ++ unwords extraArgs configFile <- defaultConfigFile --FIXME let verbosity = fromFlag verbosityFlag config <- loadConfig verbosity configFile
cabal-install.cabal view
@@ -1,5 +1,5 @@ Name: cabal-install-Version: 0.5.0+Version: 0.5.1 Synopsis: The command-line interface for Cabal and Hackage. Description: The \'cabal\' command-line program simplifies the process of managing