diff --git a/Hackage/Config.hs b/Hackage/Config.hs --- a/Hackage/Config.hs +++ b/Hackage/Config.hs @@ -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 diff --git a/Hackage/Dependency/Bogus.hs b/Hackage/Dependency/Bogus.hs --- a/Hackage/Dependency/Bogus.hs +++ b/Hackage/Dependency/Bogus.hs @@ -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)) diff --git a/Hackage/Fetch.hs b/Hackage/Fetch.hs --- a/Hackage/Fetch.hs +++ b/Hackage/Fetch.hs @@ -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 diff --git a/Hackage/HttpUtils.hs b/Hackage/HttpUtils.hs --- a/Hackage/HttpUtils.hs +++ b/Hackage/HttpUtils.hs @@ -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:" diff --git a/Hackage/IndexUtils.hs b/Hackage/IndexUtils.hs --- a/Hackage/IndexUtils.hs +++ b/Hackage/IndexUtils.hs @@ -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'. diff --git a/Hackage/Install.hs b/Hackage/Install.hs --- a/Hackage/Install.hs +++ b/Hackage/Install.hs @@ -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 diff --git a/Hackage/List.hs b/Hackage/List.hs --- a/Hackage/List.hs +++ b/Hackage/List.hs @@ -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 = diff --git a/Main.hs b/Main.hs --- a/Main.hs +++ b/Main.hs @@ -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 diff --git a/cabal-install.cabal b/cabal-install.cabal --- a/cabal-install.cabal +++ b/cabal-install.cabal @@ -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