X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=utils%2Fghc-pkg%2FMain.hs;h=52b79146b7e224f4b81731645b3a999c0ebdb7a2;hp=ee2f3196c78e4550ee0a3e281849d6782f808a91;hb=091fceaeb313c2d2504c005ddc1067ad6f9c60c6;hpb=f871cf1bf889704a4ec1f0063ad4d96f31453ea3 diff --git a/utils/ghc-pkg/Main.hs b/utils/ghc-pkg/Main.hs index ee2f319..52b7914 100644 --- a/utils/ghc-pkg/Main.hs +++ b/utils/ghc-pkg/Main.hs @@ -1,4 +1,4 @@ -{-# OPTIONS -fglasgow-exts -cpp #-} +{-# LANGUAGE PatternGuards, CPP, ForeignFunctionInterface #-} ----------------------------------------------------------------------------- -- -- (c) The University of Glasgow 2004-2009. @@ -10,6 +10,7 @@ module Main (main) where import Version ( version, targetOS, targetARCH ) +import Distribution.InstalledPackageInfo.Binary() import qualified Distribution.Simple.PackageIndex as PackageIndex import Distribution.ModuleName hiding (main) import Distribution.InstalledPackageInfo @@ -18,55 +19,56 @@ import Distribution.ParseUtils import Distribution.Package hiding (depends) import Distribution.Text import Distribution.Version -import System.FilePath +import System.FilePath as FilePath +import qualified System.FilePath.Posix as FilePath.Posix import System.Cmd ( rawSystem ) -import System.Directory ( getAppUserDataDirectory, createDirectoryIfMissing ) +import System.Directory ( getAppUserDataDirectory, createDirectoryIfMissing, + getModificationTime ) +import Text.Printf import Prelude -#include "../../includes/ghcconfig.h" - import System.Console.GetOpt -import Text.PrettyPrint -#if __GLASGOW_HASKELL__ >= 609 import qualified Control.Exception as Exception -#else -import qualified Control.Exception.Extensible as Exception -#endif import Data.Maybe import Data.Char ( isSpace, toLower ) import Control.Monad import System.Directory ( doesDirectoryExist, getDirectoryContents, - doesFileExist, renameFile, removeFile ) + doesFileExist, renameFile, removeFile, + getCurrentDirectory ) import System.Exit ( exitWith, ExitCode(..) ) import System.Environment ( getArgs, getProgName, getEnv ) import System.IO -import System.IO.Error (try) +import System.IO.Error import Data.List import Control.Concurrent +import qualified Data.ByteString.Lazy as B +import qualified Data.Binary as Bin +import qualified Data.Binary.Get as Bin + +#if defined(mingw32_HOST_OS) +-- mingw32 needs these for getExecDir, GHC <6.12 needs them for openNewFile import Foreign import Foreign.C +#endif + #ifdef mingw32_HOST_OS import GHC.ConsoleHandler #else import System.Posix hiding (fdToHandle) #endif -import IO ( isPermissionError ) -import System.Posix.Internals -#if __GLASGOW_HASKELL__ >= 611 -import GHC.IO.Handle.FD (fdToHandle) -#else -import GHC.Handle (fdToHandle) -#endif - #if defined(GLOB) import System.Process(runInteractiveCommand) import qualified System.Info(os) #endif +#if !defined(mingw32_HOST_OS) && !defined(BOOTSTRAPPING) +import System.Console.Terminfo as Terminfo +#endif + -- ----------------------------------------------------------------------------- -- Entry point @@ -101,6 +103,9 @@ data Flag | FlagForce | FlagForceFiles | FlagAutoGHCiLibs + | FlagExpandEnvVars + | FlagExpandPkgroot + | FlagNoExpandPkgroot | FlagSimpleOutput | FlagNamesOnly | FlagIgnoreCase @@ -126,6 +131,12 @@ flags = [ "ignore missing directories and libraries only", Option ['g'] ["auto-ghci-libs"] (NoArg FlagAutoGHCiLibs) "automatically build libs for GHCi (with register)", + Option [] ["expand-env-vars"] (NoArg FlagExpandEnvVars) + "expand environment variables (${name}-style) in input package descriptions", + Option [] ["expand-pkgroot"] (NoArg FlagExpandPkgroot) + "expand ${pkgroot}-relative paths to absolute in output package descriptions", + Option [] ["no-expand-pkgroot"] (NoArg FlagNoExpandPkgroot) + "preserve ${pkgroot}-relative paths in output package descriptions", Option ['?'] ["help"] (NoArg FlagHelp) "display this help and exit", Option ['V'] ["version"] (NoArg FlagVersion) @@ -163,14 +174,20 @@ ourCopyright = "GHC package manager version " ++ Version.version ++ "\n" usageHeader :: String -> String usageHeader prog = substProg prog $ "Usage:\n" ++ + " $p init {path}\n" ++ + " Create and initialise a package database at the location {path}.\n" ++ + " Packages can be registered in the new database using the register\n" ++ + " command with --package-conf={path}. To use the new database with GHC,\n" ++ + " use GHC's -package-conf flag.\n" ++ + "\n" ++ " $p register {filename | -}\n" ++ " Register the package using the specified installed package\n" ++ " description. The syntax for the latter is given in the $p\n" ++ - " documentation.\n" ++ + " documentation. The input file should be encoded in UTF-8.\n" ++ "\n" ++ " $p update {filename | -}\n" ++ " Register the package, overwriting any other package with the\n" ++ - " same name.\n" ++ + " same name. The input file should be encoded in UTF-8.\n" ++ "\n" ++ " $p unregister {pkg-id}\n" ++ " Unregister the specified package.\n" ++ @@ -217,7 +234,15 @@ usageHeader prog = substProg prog $ " $p dump\n" ++ " Dump the registered description for every package. This is like\n" ++ " \"ghc-pkg describe '*'\", except that it is intended to be used\n" ++ - " by tools that parse the results, rather than humans.\n" ++ + " by tools that parse the results, rather than humans. The output is\n" ++ + " always encoded in UTF-8, regardless of the current locale.\n" ++ + "\n" ++ + " $p recache\n" ++ + " Regenerate the package database cache. This command should only be\n" ++ + " necessary if you added a package to the database by dropping a file\n" ++ + " into the database directory manually. By default, the global DB\n" ++ + " is recached; to recache a different DB use --user or --package-conf\n" ++ + " as appropriate.\n" ++ "\n" ++ " Substring matching is supported for {module} in find-module and\n" ++ " for {pkg} in list, describe, and field, where a '*' indicates\n" ++ @@ -260,6 +285,12 @@ runit verbosity cli nonopts = do | FlagForceFiles `elem` cli = ForceFiles | otherwise = NoForce auto_ghci_libs = FlagAutoGHCiLibs `elem` cli + expand_env_vars= FlagExpandEnvVars `elem` cli + mexpand_pkgroot= foldl' accumExpandPkgroot Nothing cli + where accumExpandPkgroot _ FlagExpandPkgroot = Just True + accumExpandPkgroot _ FlagNoExpandPkgroot = Just False + accumExpandPkgroot x _ = x + splitFields fields = unfoldr splitComma (',':fields) where splitComma "" = Nothing splitComma fs = Just $ break (==',') (tail fs) @@ -296,10 +327,14 @@ runit verbosity cli nonopts = do print filename glob filename >>= print #endif + ["init", filename] -> + initPackageDB filename verbosity cli ["register", filename] -> - registerPackage filename verbosity cli auto_ghci_libs False force + registerPackage filename verbosity cli + auto_ghci_libs expand_env_vars False force ["update", filename] -> - registerPackage filename verbosity cli auto_ghci_libs True force + registerPackage filename verbosity cli + auto_ghci_libs expand_env_vars True force ["unregister", pkgid_str] -> do pkgid <- readGlobPkgId pkgid_str unregisterPackage pkgid verbosity cli force @@ -323,23 +358,28 @@ runit verbosity cli nonopts = do listPackages verbosity cli Nothing (Just match) ["latest", pkgid_str] -> do pkgid <- readGlobPkgId pkgid_str - latestPackage cli pkgid - ["describe", pkgid_str] -> - case substringCheck pkgid_str of - Nothing -> do pkgid <- readGlobPkgId pkgid_str - describePackage cli (Id pkgid) - Just m -> describePackage cli (Substring pkgid_str m) - ["field", pkgid_str, fields] -> - case substringCheck pkgid_str of - Nothing -> do pkgid <- readGlobPkgId pkgid_str - describeField cli (Id pkgid) (splitFields fields) - Just m -> describeField cli (Substring pkgid_str m) - (splitFields fields) + latestPackage verbosity cli pkgid + ["describe", pkgid_str] -> do + pkgarg <- case substringCheck pkgid_str of + Nothing -> liftM Id (readGlobPkgId pkgid_str) + Just m -> return (Substring pkgid_str m) + describePackage verbosity cli pkgarg (fromMaybe False mexpand_pkgroot) + + ["field", pkgid_str, fields] -> do + pkgarg <- case substringCheck pkgid_str of + Nothing -> liftM Id (readGlobPkgId pkgid_str) + Just m -> return (Substring pkgid_str m) + describeField verbosity cli pkgarg + (splitFields fields) (fromMaybe True mexpand_pkgroot) + ["check"] -> do - checkConsistency cli + checkConsistency verbosity cli ["dump"] -> do - dumpPackages cli + dumpPackages verbosity cli (fromMaybe False mexpand_pkgroot) + + ["recache"] -> do + recache verbosity cli [] -> do die ("missing command\n" ++ @@ -381,19 +421,42 @@ globVersion = Version{ versionBranch=[], versionTags=["*"] } -- Some commands operate on multiple databases, with overlapping semantics: -- list, describe, field -type PackageDBName = FilePath -type PackageDB = [InstalledPackageInfo] - -type NamedPackageDB = (PackageDBName, PackageDB) -type PackageDBStack = [NamedPackageDB] +data PackageDB + = PackageDB { + location, locationAbsolute :: !FilePath, + -- We need both possibly-relative and definately-absolute package + -- db locations. This is because the relative location is used as + -- an identifier for the db, so it is important we do not modify it. + -- On the other hand we need the absolute path in a few places + -- particularly in relation to the ${pkgroot} stuff. + + packages :: [InstalledPackageInfo] + } + +type PackageDBStack = [PackageDB] -- A stack of package databases. Convention: head is the topmost - -- in the stack. Earlier entries override later one. + -- in the stack. allPackagesInStack :: PackageDBStack -> [InstalledPackageInfo] -allPackagesInStack = concatMap snd +allPackagesInStack = concatMap packages -getPkgDatabases :: Bool -> [Flag] -> IO (PackageDBStack, Maybe PackageDBName) -getPkgDatabases modify my_flags = do +getPkgDatabases :: Verbosity + -> Bool -- we are modifying, not reading + -> Bool -- read caches, if available + -> Bool -- expand vars, like ${pkgroot} and $topdir + -> [Flag] + -> IO (PackageDBStack, + -- the real package DB stack: [global,user] ++ + -- DBs specified on the command line with -f. + Maybe FilePath, + -- which one to modify, if any + PackageDBStack) + -- the package DBs specified on the command + -- line, or [global,user] otherwise. This + -- is used as the list of package DBs for + -- commands that just read the DB, such as 'list'. + +getPkgDatabases verbosity modify use_cache expand_vars my_flags = do -- first we determine the location of the global package config. On Windows, -- this is found relative to the ghc-pkg.exe binary, whereas on Unix the -- location is passed to the binary using the --global-config flag by the @@ -403,49 +466,46 @@ getPkgDatabases modify my_flags = do case [ f | FlagGlobalConfig f <- my_flags ] of [] -> do mb_dir <- getLibDir case mb_dir of - Nothing -> die err_msg - Just dir -> - do let path = dir "package.conf" - exists <- doesFileExist path - unless exists $ die "Can't find package.conf" - return path + Nothing -> die err_msg + Just dir -> do + r <- lookForPackageDBIn dir + case r of + Nothing -> die ("Can't find package database in " ++ dir) + Just path -> return path fs -> return (last fs) - let global_conf_dir = global_conf ++ ".d" - global_conf_dir_exists <- doesDirectoryExist global_conf_dir - global_confs <- - if global_conf_dir_exists - then do files <- getDirectoryContents global_conf_dir - return [ global_conf_dir ++ '/' : file - | file <- files - , isSuffixOf ".conf" file] - else return [] + -- The value of the $topdir variable used in some package descriptions + -- Note that the way we calculate this is slightly different to how it + -- is done in ghc itself. We rely on the convention that the global + -- package db lives in ghc's libdir. + top_dir <- absolutePath (takeDirectory global_conf) let no_user_db = FlagNoUserDb `elem` my_flags -- get the location of the user package database, and create it if necessary -- getAppUserDataDirectory can fail (e.g. if $HOME isn't set) - appdir <- try $ getAppUserDataDirectory "ghc" + e_appdir <- tryIO $ getAppUserDataDirectory "ghc" mb_user_conf <- if no_user_db then return Nothing else - case appdir of - Right dir -> do - let subdir = targetARCH ++ '-':targetOS ++ '-':Version.version - user_conf = dir subdir "package.conf" - user_exists <- doesFileExist user_conf - return (Just (user_conf,user_exists)) - Left _ -> - return Nothing + case e_appdir of + Left _ -> return Nothing + Right appdir -> do + let subdir = targetARCH ++ '-':targetOS ++ '-':Version.version + dir = appdir subdir + r <- lookForPackageDBIn dir + case r of + Nothing -> return (Just (dir "package.conf.d", False)) + Just f -> return (Just (f, True)) -- If the user database doesn't exist, and this command isn't a -- "modify" command, then we won't attempt to create or use it. let sys_databases | Just (user_conf,user_exists) <- mb_user_conf, - modify || user_exists = user_conf : global_confs ++ [global_conf] - | otherwise = global_confs ++ [global_conf] + modify || user_exists = [user_conf, global_conf] + | otherwise = [global_conf] - e_pkg_path <- try (System.Environment.getEnv "GHC_PACKAGE_PATH") + e_pkg_path <- tryIO (System.Environment.getEnv "GHC_PACKAGE_PATH") let env_stack = case e_pkg_path of Left _ -> sys_databases @@ -466,52 +526,208 @@ getPkgDatabases modify my_flags = do is_db_flag (FlagConfig f) = Just f is_db_flag _ = Nothing - (final_stack, to_modify) <- - if not modify - then -- For a "read" command, we use all the databases - -- specified on the command line. If there are no - -- command-line flags specifying databases, the default - -- is to use all the ones we know about. - if null db_flags then return (env_stack, Nothing) - else return (reverse (nub db_flags), Nothing) - else let - -- For a "modify" command, treat all the databases as - -- a stack, where we are modifying the top one, but it - -- can refer to packages in databases further down the - -- stack. - - -- -f flags on the command line add to the database - -- stack, unless any of them are present in the stack - -- already. - flag_stack = filter (`notElem` env_stack) - [ f | FlagConfig f <- reverse my_flags ] - ++ env_stack - - -- the database we actually modify is the one mentioned - -- rightmost on the command-line. - to_modify = if null db_flags - then Just virt_global_conf - else Just (last db_flags) - in - return (flag_stack, to_modify) - - db_stack <- mapM (readParseDatabase mb_user_conf) final_stack - return (db_stack, to_modify) - -readParseDatabase :: Maybe (PackageDBName,Bool) - -> PackageDBName - -> IO (PackageDBName,PackageDB) -readParseDatabase mb_user_conf filename + let flag_db_names | null db_flags = env_stack + | otherwise = reverse (nub db_flags) + + -- For a "modify" command, treat all the databases as + -- a stack, where we are modifying the top one, but it + -- can refer to packages in databases further down the + -- stack. + + -- -f flags on the command line add to the database + -- stack, unless any of them are present in the stack + -- already. + let final_stack = filter (`notElem` env_stack) + [ f | FlagConfig f <- reverse my_flags ] + ++ env_stack + + -- the database we actually modify is the one mentioned + -- rightmost on the command-line. + let to_modify + | not modify = Nothing + | null db_flags = Just virt_global_conf + | otherwise = Just (last db_flags) + + db_stack <- sequence + [ do db <- readParseDatabase verbosity mb_user_conf use_cache db_path + if expand_vars then return (mungePackageDBPaths top_dir db) + else return db + | db_path <- final_stack ] + + let flag_db_stack = [ db | db_name <- flag_db_names, + db <- db_stack, location db == db_name ] + + return (db_stack, to_modify, flag_db_stack) + + +lookForPackageDBIn :: FilePath -> IO (Maybe FilePath) +lookForPackageDBIn dir = do + let path_dir = dir "package.conf.d" + exists_dir <- doesDirectoryExist path_dir + if exists_dir then return (Just path_dir) else do + let path_file = dir "package.conf" + exists_file <- doesFileExist path_file + if exists_file then return (Just path_file) else return Nothing + +readParseDatabase :: Verbosity + -> Maybe (FilePath,Bool) + -> Bool -- use cache + -> FilePath + -> IO PackageDB + +readParseDatabase verbosity mb_user_conf use_cache path -- the user database (only) is allowed to be non-existent - | Just (user_conf,False) <- mb_user_conf, filename == user_conf - = return (filename, []) + | Just (user_conf,False) <- mb_user_conf, path == user_conf + = mkPackageDB [] | otherwise - = do str <- readFile filename - let packages = map convertPackageInfoIn $ read str - _ <- Exception.evaluate packages - `catchError` \e-> - die ("error while parsing " ++ filename ++ ": " ++ show e) - return (filename,packages) + = do e <- tryIO $ getDirectoryContents path + case e of + Left _ -> do + pkgs <- parseMultiPackageConf verbosity path + mkPackageDB pkgs + Right fs + | not use_cache -> ignore_cache + | otherwise -> do + let cache = path cachefilename + tdir <- getModificationTime path + e_tcache <- tryIO $ getModificationTime cache + case e_tcache of + Left ex -> do + when (verbosity > Normal) $ + warn ("warning: cannot read cache file " ++ cache ++ ": " ++ show ex) + ignore_cache + Right tcache + | tcache >= tdir -> do + when (verbosity > Normal) $ + putStrLn ("using cache: " ++ cache) + pkgs <- myReadBinPackageDB cache + let pkgs' = map convertPackageInfoIn pkgs + mkPackageDB pkgs' + | otherwise -> do + when (verbosity >= Normal) $ do + warn ("WARNING: cache is out of date: " ++ cache) + warn " use 'ghc-pkg recache' to fix." + ignore_cache + where + ignore_cache = do + let confs = filter (".conf" `isSuffixOf`) fs + pkgs <- mapM (parseSingletonPackageConf verbosity) $ + map (path ) confs + mkPackageDB pkgs + where + mkPackageDB pkgs = do + path_abs <- absolutePath path + return PackageDB { + location = path, + locationAbsolute = path_abs, + packages = pkgs + } + +-- read the package.cache file strictly, to work around a problem with +-- bytestring 0.9.0.x (fixed in 0.9.1.x) where the file wasn't closed +-- after it has been completely read, leading to a sharing violation +-- later. +myReadBinPackageDB :: FilePath -> IO [InstalledPackageInfoString] +myReadBinPackageDB filepath = do + h <- openBinaryFile filepath ReadMode + sz <- hFileSize h + b <- B.hGet h (fromIntegral sz) + hClose h + return $ Bin.runGet Bin.get b + +parseMultiPackageConf :: Verbosity -> FilePath -> IO [InstalledPackageInfo] +parseMultiPackageConf verbosity file = do + when (verbosity > Normal) $ putStrLn ("reading package database: " ++ file) + str <- readUTF8File file + let pkgs = map convertPackageInfoIn $ read str + Exception.evaluate pkgs + `catchError` \e-> + die ("error while parsing " ++ file ++ ": " ++ show e) + +parseSingletonPackageConf :: Verbosity -> FilePath -> IO InstalledPackageInfo +parseSingletonPackageConf verbosity file = do + when (verbosity > Normal) $ putStrLn ("reading package config: " ++ file) + readUTF8File file >>= fmap fst . parsePackageInfo + +cachefilename :: FilePath +cachefilename = "package.cache" + +mungePackageDBPaths :: FilePath -> PackageDB -> PackageDB +mungePackageDBPaths top_dir db@PackageDB { packages = pkgs } = + db { packages = map (mungePackagePaths top_dir pkgroot) pkgs } + where + pkgroot = takeDirectory (locationAbsolute db) + -- It so happens that for both styles of package db ("package.conf" + -- files and "package.conf.d" dirs) the pkgroot is the parent directory + -- ${pkgroot}/package.conf or ${pkgroot}/package.conf.d/ + +-- TODO: This code is duplicated in compiler/main/Packages.lhs +mungePackagePaths :: FilePath -> FilePath + -> InstalledPackageInfo -> InstalledPackageInfo +-- Perform path/URL variable substitution as per the Cabal ${pkgroot} spec +-- (http://www.haskell.org/pipermail/libraries/2009-May/011772.html) +-- Paths/URLs can be relative to ${pkgroot} or ${pkgrooturl}. +-- The "pkgroot" is the directory containing the package database. +-- +-- Also perform a similar substitution for the older GHC-specific +-- "$topdir" variable. The "topdir" is the location of the ghc +-- installation (obtained from the -B option). +mungePackagePaths top_dir pkgroot pkg = + pkg { + importDirs = munge_paths (importDirs pkg), + includeDirs = munge_paths (includeDirs pkg), + libraryDirs = munge_paths (libraryDirs pkg), + frameworkDirs = munge_paths (frameworkDirs pkg), + haddockInterfaces = munge_paths (haddockInterfaces pkg), + -- haddock-html is allowed to be either a URL or a file + haddockHTMLs = munge_paths (munge_urls (haddockHTMLs pkg)) + } + where + munge_paths = map munge_path + munge_urls = map munge_url + + munge_path p + | Just p' <- stripVarPrefix "${pkgroot}" p = pkgroot ++ p' + | Just p' <- stripVarPrefix "$topdir" p = top_dir ++ p' + | otherwise = p + + munge_url p + | Just p' <- stripVarPrefix "${pkgrooturl}" p = toUrlPath pkgroot p' + | Just p' <- stripVarPrefix "$httptopdir" p = toUrlPath top_dir p' + | otherwise = p + + toUrlPath r p = "file:///" + -- URLs always use posix style '/' separators: + ++ FilePath.Posix.joinPath + (r : -- We need to drop a leading "/" or "\\" + -- if there is one: + dropWhile (all isPathSeparator) + (FilePath.splitDirectories p)) + + -- We could drop the separator here, and then use above. However, + -- by leaving it in and using ++ we keep the same path separator + -- rather than letting FilePath change it to use \ as the separator + stripVarPrefix var path = case stripPrefix var path of + Just [] -> Just [] + Just cs@(c : _) | isPathSeparator c -> Just cs + _ -> Nothing + + +-- ----------------------------------------------------------------------------- +-- Creating a new package DB + +initPackageDB :: FilePath -> Verbosity -> [Flag] -> IO () +initPackageDB filename verbosity _flags = do + let eexist = die ("cannot create: " ++ filename ++ " already exists") + b1 <- doesFileExist filename + when b1 eexist + b2 <- doesDirectoryExist filename + when b2 eexist + filename_abs <- absolutePath filename + changeDB verbosity [] PackageDB { + location = filename, locationAbsolute = filename_abs, + packages = [] + } -- ----------------------------------------------------------------------------- -- Registering @@ -520,86 +736,164 @@ registerPackage :: FilePath -> Verbosity -> [Flag] -> Bool -- auto_ghci_libs + -> Bool -- expand_env_vars -> Bool -- update -> Force -> IO () -registerPackage input verbosity my_flags auto_ghci_libs update force = do - (db_stack, Just to_modify) <- getPkgDatabases True my_flags +registerPackage input verbosity my_flags auto_ghci_libs expand_env_vars update force = do + (db_stack, Just to_modify, _flag_dbs) <- + getPkgDatabases verbosity True True False{-expand vars-} my_flags + let db_to_operate_on = my_head "register" $ - filter ((== to_modify).fst) db_stack + filter ((== to_modify).location) db_stack + -- + when (auto_ghci_libs && verbosity >= Silent) $ + warn "Warning: --auto-ghci-libs is deprecated and will be removed in GHC 7.4" -- s <- case input of "-" -> do when (verbosity >= Normal) $ putStr "Reading package info from stdin ... " + -- fix the encoding to UTF-8, since this is an interchange format + hSetEncoding stdin utf8 getContents f -> do when (verbosity >= Normal) $ putStr ("Reading package info from " ++ show f ++ " ... ") - readFile f + readUTF8File f - expanded <- expandEnvVars s force + expanded <- if expand_env_vars then expandEnvVars s force + else return s - pkg <- parsePackageInfo expanded + (pkg, ws) <- parsePackageInfo expanded when (verbosity >= Normal) $ putStrLn "done." - let truncated_stack = dropWhile ((/= to_modify).fst) db_stack + -- report any warnings from the parse phase + _ <- reportValidateErrors [] ws + (display (sourcePackageId pkg) ++ ": Warning: ") Nothing + + -- validate the expanded pkg, but register the unexpanded + pkgroot <- absolutePath (takeDirectory to_modify) + let top_dir = takeDirectory (location (last db_stack)) + pkg_expanded = mungePackagePaths top_dir pkgroot pkg + + let truncated_stack = dropWhile ((/= to_modify).location) db_stack -- truncate the stack for validation, because we don't allow -- packages lower in the stack to refer to those higher up. - validatePackageConfig pkg truncated_stack auto_ghci_libs update force - let new_details = filter not_this (snd db_to_operate_on) ++ [pkg] - not_this p = sourcePackageId p /= sourcePackageId pkg - writeNewConfig verbosity to_modify new_details + validatePackageConfig pkg_expanded truncated_stack auto_ghci_libs update force + let + removes = [ RemovePackage p + | p <- packages db_to_operate_on, + sourcePackageId p == sourcePackageId pkg ] + -- + changeDB verbosity (removes ++ [AddPackage pkg]) db_to_operate_on parsePackageInfo :: String - -> IO InstalledPackageInfo + -> IO (InstalledPackageInfo, [ValidateWarning]) parsePackageInfo str = case parseInstalledPackageInfo str of - ParseOk _warns ok -> return ok + ParseOk warnings ok -> return (ok, ws) + where + ws = [ msg | PWarning msg <- warnings + , not ("Unrecognized field pkgroot" `isPrefixOf` msg) ] ParseFailed err -> case locatedErrorMsg err of (Nothing, s) -> die s (Just l, s) -> die (show l ++ ": " ++ s) -- ----------------------------------------------------------------------------- +-- Making changes to a package database + +data DBOp = RemovePackage InstalledPackageInfo + | AddPackage InstalledPackageInfo + | ModifyPackage InstalledPackageInfo + +changeDB :: Verbosity -> [DBOp] -> PackageDB -> IO () +changeDB verbosity cmds db = do + let db' = updateInternalDB db cmds + isfile <- doesFileExist (location db) + if isfile + then writeNewConfig verbosity (location db') (packages db') + else do + createDirectoryIfMissing True (location db) + changeDBDir verbosity cmds db' + +updateInternalDB :: PackageDB -> [DBOp] -> PackageDB +updateInternalDB db cmds = db{ packages = foldl do_cmd (packages db) cmds } + where + do_cmd pkgs (RemovePackage p) = + filter ((/= installedPackageId p) . installedPackageId) pkgs + do_cmd pkgs (AddPackage p) = p : pkgs + do_cmd pkgs (ModifyPackage p) = + do_cmd (do_cmd pkgs (RemovePackage p)) (AddPackage p) + + +changeDBDir :: Verbosity -> [DBOp] -> PackageDB -> IO () +changeDBDir verbosity cmds db = do + mapM_ do_cmd cmds + updateDBCache verbosity db + where + do_cmd (RemovePackage p) = do + let file = location db display (installedPackageId p) <.> "conf" + when (verbosity > Normal) $ putStrLn ("removing " ++ file) + removeFileSafe file + do_cmd (AddPackage p) = do + let file = location db display (installedPackageId p) <.> "conf" + when (verbosity > Normal) $ putStrLn ("writing " ++ file) + writeFileUtf8Atomic file (showInstalledPackageInfo p) + do_cmd (ModifyPackage p) = + do_cmd (AddPackage p) + +updateDBCache :: Verbosity -> PackageDB -> IO () +updateDBCache verbosity db = do + let filename = location db cachefilename + when (verbosity > Normal) $ + putStrLn ("writing cache " ++ filename) + writeBinaryFileAtomic filename (map convertPackageInfoOut (packages db)) + `catchIO` \e -> + if isPermissionError e + then die (filename ++ ": you don't have permission to modify this file") + else ioError e + +-- ----------------------------------------------------------------------------- -- Exposing, Hiding, Unregistering are all similar exposePackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO () -exposePackage = modifyPackage (\p -> [p{exposed=True}]) +exposePackage = modifyPackage (\p -> ModifyPackage p{exposed=True}) hidePackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO () -hidePackage = modifyPackage (\p -> [p{exposed=False}]) +hidePackage = modifyPackage (\p -> ModifyPackage p{exposed=False}) unregisterPackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO () -unregisterPackage = modifyPackage (\_ -> []) +unregisterPackage = modifyPackage RemovePackage modifyPackage - :: (InstalledPackageInfo -> [InstalledPackageInfo]) + :: (InstalledPackageInfo -> DBOp) -> PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO () modifyPackage fn pkgid verbosity my_flags force = do - (db_stack, Just _to_modify) <- getPkgDatabases True{-modify-} my_flags - ((db_name, pkgs), ps) <- fmap head $ findPackagesByDB db_stack (Id pkgid) --- let ((db_name, pkgs) : rest_of_stack) = db_stack --- ps <- findPackages [(db_name,pkgs)] (Id pkgid) + (db_stack, Just _to_modify, _flag_dbs) <- + getPkgDatabases verbosity True{-modify-} True{-use cache-} False{-expand vars-} my_flags + + (db, ps) <- fmap head $ findPackagesByDB db_stack (Id pkgid) let + db_name = location db + pkgs = packages db + pids = map sourcePackageId ps - modify pkg - | sourcePackageId pkg `elem` pids = fn pkg - | otherwise = [pkg] - new_config = concat (map modify pkgs) - let + cmds = [ fn pkg | pkg <- pkgs, sourcePackageId pkg `elem` pids ] + new_db = updateInternalDB db cmds + old_broken = brokenPackages (allPackagesInStack db_stack) - rest_of_stack = [ (nm, mypkgs) - | (nm, mypkgs) <- db_stack, nm /= db_name ] - new_stack = (db_name,new_config) : rest_of_stack + rest_of_stack = filter ((/= db_name) . location) db_stack + new_stack = new_db : rest_of_stack new_broken = map sourcePackageId (brokenPackages (allPackagesInStack new_stack)) newly_broken = filter (`notElem` map sourcePackageId old_broken) new_broken -- @@ -608,7 +902,17 @@ modifyPackage fn pkgid verbosity my_flags force = do " would break the following packages: " ++ unwords (map display newly_broken)) - writeNewConfig verbosity db_name new_config + changeDB verbosity cmds db + +recache :: Verbosity -> [Flag] -> IO () +recache verbosity my_flags = do + (db_stack, Just to_modify, _flag_dbs) <- + getPkgDatabases verbosity True{-modify-} False{-no cache-} False{-expand vars-} my_flags + let + db_to_operate_on = my_head "recache" $ + filter ((== to_modify).location) db_stack + -- + changeDB verbosity [] db_to_operate_on -- ----------------------------------------------------------------------------- -- Listing packages @@ -618,18 +922,21 @@ listPackages :: Verbosity -> [Flag] -> Maybe PackageArg -> IO () listPackages verbosity my_flags mPackageName mModuleName = do let simple_output = FlagSimpleOutput `elem` my_flags - (db_stack, _) <- getPkgDatabases False my_flags + (db_stack, _, flag_db_stack) <- + getPkgDatabases verbosity False True{-use cache-} False{-expand vars-} my_flags + let db_stack_filtered -- if a package is given, filter out all other packages | Just this <- mPackageName = - map (\(conf,pkgs) -> (conf, filter (this `matchesPkg`) pkgs)) - db_stack + [ db{ packages = filter (this `matchesPkg`) (packages db) } + | db <- flag_db_stack ] | Just match <- mModuleName = -- packages which expose mModuleName - map (\(conf,pkgs) -> (conf, filter (match `exposedInPkg`) pkgs)) - db_stack - | otherwise = db_stack + [ db{ packages = filter (match `exposedInPkg`) (packages db) } + | db <- flag_db_stack ] + | otherwise = flag_db_stack db_stack_sorted - = [ (db, sort_pkgs pkgs) | (db,pkgs) <- db_stack_filtered ] + = [ db{ packages = sort_pkgs (packages db) } + | db <- db_stack_filtered ] where sort_pkgs = sortBy cmpPkgIds cmpPkgIds pkg1 pkg2 = case pkgName p1 `compare` pkgName p2 of @@ -638,38 +945,65 @@ listPackages verbosity my_flags mPackageName mModuleName = do EQ -> pkgVersion p1 `compare` pkgVersion p2 where (p1,p2) = (sourcePackageId pkg1, sourcePackageId pkg2) + stack = reverse db_stack_sorted + match `exposedInPkg` pkg = any match (map display $ exposedModules pkg) pkg_map = allPackagesInStack db_stack broken = map sourcePackageId (brokenPackages pkg_map) - show_func = if simple_output then show_simple else mapM_ show_normal - - show_normal (db_name,pkg_confs) = - hPutStrLn stdout (render $ - text db_name <> colon $$ nest 4 packages - ) - where packages - | verbosity >= Verbose = vcat (map pp_pkg pkg_confs) - | otherwise = fsep (punctuate comma (map pp_pkg pkg_confs)) + show_normal PackageDB{ location = db_name, packages = pkg_confs } = + hPutStrLn stdout $ unlines ((db_name ++ ":") : map (" " ++) pp_pkgs) + where + pp_pkgs = map pp_pkg pkg_confs pp_pkg p - | sourcePackageId p `elem` broken = braces doc + | sourcePackageId p `elem` broken = printf "{%s}" doc | exposed p = doc - | otherwise = parens doc - where doc | verbosity >= Verbose = pkg <+> parens ipid + | otherwise = printf "(%s)" doc + where doc | verbosity >= Verbose = printf "%s (%s)" pkg ipid | otherwise = pkg where - InstalledPackageId ipid_str = installedPackageId p - ipid = text ipid_str - pkg = text (display (sourcePackageId p)) + InstalledPackageId ipid = installedPackageId p + pkg = display (sourcePackageId p) show_simple = simplePackageList my_flags . allPackagesInStack - when (not (null broken) && verbosity /= Silent) $ do + when (not (null broken) && not simple_output && verbosity /= Silent) $ do prog <- getProgramName - putStrLn ("WARNING: there are broken packages. Run '" ++ prog ++ " check' for more details.") + warn ("WARNING: there are broken packages. Run '" ++ prog ++ " check' for more details.") - show_func (reverse db_stack_sorted) + if simple_output then show_simple stack else do + +#if defined(mingw32_HOST_OS) || defined(BOOTSTRAPPING) + mapM_ show_normal stack +#else + let + show_colour withF db = + mconcat $ map (<#> termText "\n") $ + (termText (location db) : + map (termText " " <#>) (map pp_pkg (packages db))) + where + pp_pkg p + | sourcePackageId p `elem` broken = withF Red doc + | exposed p = doc + | otherwise = withF Blue doc + where doc | verbosity >= Verbose + = termText (printf "%s (%s)" pkg ipid) + | otherwise + = termText pkg + where + InstalledPackageId ipid = installedPackageId p + pkg = display (sourcePackageId p) + + is_tty <- hIsTerminalDevice stdout + if not is_tty + then mapM_ show_normal stack + else do tty <- Terminfo.setupTermFromEnv + case Terminfo.getCapability tty withForegroundColor of + Nothing -> mapM_ show_normal stack + Just w -> runTermOutput tty $ mconcat $ + map (show_colour w) stack +#endif simplePackageList :: [Flag] -> [InstalledPackageInfo] -> IO () simplePackageList my_flags pkgs = do @@ -680,10 +1014,12 @@ simplePackageList my_flags pkgs = do hPutStrLn stdout $ concat $ intersperse " " strs showPackageDot :: Verbosity -> [Flag] -> IO () -showPackageDot _verbosity myflags = do - (db_stack, _) <- getPkgDatabases False myflags - let all_pkgs = allPackagesInStack db_stack - ipix = PackageIndex.listToInstalledPackageIndex all_pkgs +showPackageDot verbosity myflags = do + (_, _, flag_db_stack) <- + getPkgDatabases verbosity False True{-use cache-} False{-expand vars-} myflags + + let all_pkgs = allPackagesInStack flag_db_stack + ipix = PackageIndex.fromList all_pkgs putStrLn "digraph {" let quote s = '"':s ++ "\"" @@ -691,7 +1027,7 @@ showPackageDot _verbosity myflags = do | p <- all_pkgs, let from = display (sourcePackageId p), depid <- depends p, - Just dep <- [PackageIndex.lookupInstalledPackage ipix depid], + Just dep <- [PackageIndex.lookupInstalledPackageId ipix depid], let to = display (sourcePackageId dep) ] putStrLn "}" @@ -699,10 +1035,12 @@ showPackageDot _verbosity myflags = do -- ----------------------------------------------------------------------------- -- Prints the highest (hidden or exposed) version of a package -latestPackage :: [Flag] -> PackageIdentifier -> IO () -latestPackage my_flags pkgid = do - (db_stack, _) <- getPkgDatabases False my_flags - ps <- findPackages db_stack (Id pkgid) +latestPackage :: Verbosity -> [Flag] -> PackageIdentifier -> IO () +latestPackage verbosity my_flags pkgid = do + (_, _, flag_db_stack) <- + getPkgDatabases verbosity False True{-use cache-} False{-expand vars-} my_flags + + ps <- findPackages flag_db_stack (Id pkgid) show_pkg (sortBy compPkgIdVer (map sourcePackageId ps)) where show_pkg [] = die "no matches" @@ -711,19 +1049,33 @@ latestPackage my_flags pkgid = do -- ----------------------------------------------------------------------------- -- Describe -describePackage :: [Flag] -> PackageArg -> IO () -describePackage my_flags pkgarg = do - (db_stack, _) <- getPkgDatabases False my_flags - ps <- findPackages db_stack pkgarg - doDump ps - -dumpPackages :: [Flag] -> IO () -dumpPackages my_flags = do - (db_stack, _) <- getPkgDatabases False my_flags - doDump (allPackagesInStack db_stack) - -doDump :: [InstalledPackageInfo] -> IO () -doDump = mapM_ putStrLn . intersperse "---" . map showInstalledPackageInfo +describePackage :: Verbosity -> [Flag] -> PackageArg -> Bool -> IO () +describePackage verbosity my_flags pkgarg expand_pkgroot = do + (_, _, flag_db_stack) <- + getPkgDatabases verbosity False True{-use cache-} expand_pkgroot my_flags + dbs <- findPackagesByDB flag_db_stack pkgarg + doDump expand_pkgroot [ (pkg, locationAbsolute db) + | (db, pkgs) <- dbs, pkg <- pkgs ] + +dumpPackages :: Verbosity -> [Flag] -> Bool -> IO () +dumpPackages verbosity my_flags expand_pkgroot = do + (_, _, flag_db_stack) <- + getPkgDatabases verbosity False True{-use cache-} expand_pkgroot my_flags + doDump expand_pkgroot [ (pkg, locationAbsolute db) + | db <- flag_db_stack, pkg <- packages db ] + +doDump :: Bool -> [(InstalledPackageInfo, FilePath)] -> IO () +doDump expand_pkgroot pkgs = do + -- fix the encoding to UTF-8, since this is an interchange format + hSetEncoding stdout utf8 + putStrLn $ + intercalate "---\n" + [ if expand_pkgroot + then showInstalledPackageInfo pkg + else showInstalledPackageInfo pkg ++ pkgrootField + | (pkg, pkgloc) <- pkgs + , let pkgroot = takeDirectory pkgloc + pkgrootField = "pkgroot: " ++ pkgroot ++ "\n" ] -- PackageId is can have globVersion for the version findPackages :: PackageDBStack -> PackageArg -> IO [InstalledPackageInfo] @@ -731,11 +1083,11 @@ findPackages db_stack pkgarg = fmap (concatMap snd) $ findPackagesByDB db_stack pkgarg findPackagesByDB :: PackageDBStack -> PackageArg - -> IO [(NamedPackageDB, [InstalledPackageInfo])] + -> IO [(PackageDB, [InstalledPackageInfo])] findPackagesByDB db_stack pkgarg = case [ (db, matched) - | db@(_, pkgs) <- db_stack, - let matched = filter (pkgarg `matchesPkg`) pkgs, + | db <- db_stack, + let matched = filter (pkgarg `matchesPkg`) (packages db), not (null matched) ] of [] -> die ("cannot find package " ++ pkg_msg pkgarg) ps -> return ps @@ -762,13 +1114,13 @@ compPkgIdVer p1 p2 = pkgVersion p1 `compare` pkgVersion p2 -- ----------------------------------------------------------------------------- -- Field -describeField :: [Flag] -> PackageArg -> [String] -> IO () -describeField my_flags pkgarg fields = do - (db_stack, _) <- getPkgDatabases False my_flags +describeField :: Verbosity -> [Flag] -> PackageArg -> [String] -> Bool -> IO () +describeField verbosity my_flags pkgarg fields expand_pkgroot = do + (_, _, flag_db_stack) <- + getPkgDatabases verbosity False True{-use cache-} expand_pkgroot my_flags fns <- toFields fields - ps <- findPackages db_stack pkgarg - let top_dir = takeDirectory (fst (last db_stack)) - mapM_ (selectFields fns) (mungePackagePaths top_dir ps) + ps <- findPackages flag_db_stack pkgarg + mapM_ (selectFields fns) ps where toFields [] = return [] toFields (f:fs) = case toField f of Nothing -> die ("unknown field: " ++ f) @@ -776,35 +1128,6 @@ describeField my_flags pkgarg fields = do return (fn:fns) selectFields fns info = mapM_ (\fn->putStrLn (fn info)) fns -mungePackagePaths :: String -> [InstalledPackageInfo] -> [InstalledPackageInfo] --- Replace the strings "$topdir" and "$httptopdir" at the beginning of a path --- with the current topdir (obtained from the -B option). -mungePackagePaths top_dir ps = map munge_pkg ps - where - munge_pkg p = p{ importDirs = munge_paths (importDirs p), - includeDirs = munge_paths (includeDirs p), - libraryDirs = munge_paths (libraryDirs p), - frameworkDirs = munge_paths (frameworkDirs p), - haddockInterfaces = munge_paths (haddockInterfaces p), - haddockHTMLs = munge_paths (haddockHTMLs p) - } - - munge_paths = map munge_path - - munge_path p - | Just p' <- maybePrefixMatch "$topdir" p = top_dir ++ p' - | Just p' <- maybePrefixMatch "$httptopdir" p = toHttpPath top_dir ++ p' - | otherwise = p - - toHttpPath p = "file:///" ++ p - -maybePrefixMatch :: String -> String -> Maybe String -maybePrefixMatch [] rest = Just rest -maybePrefixMatch (_:_) [] = Nothing -maybePrefixMatch (p:pat) (r:rest) - | p == r = maybePrefixMatch pat rest - | otherwise = Nothing - toField :: String -> Maybe (InstalledPackageInfo -> String) -- backwards compatibility: toField "import_dirs" = Just $ strList . importDirs @@ -828,9 +1151,10 @@ strList = show -- ----------------------------------------------------------------------------- -- Check: Check consistency of installed packages -checkConsistency :: [Flag] -> IO () -checkConsistency my_flags = do - (db_stack, _) <- getPkgDatabases True my_flags +checkConsistency :: Verbosity -> [Flag] -> IO () +checkConsistency verbosity my_flags = do + (db_stack, _, _) <- + getPkgDatabases verbosity True True{-use cache-} True{-expand vars-} my_flags -- check behaves like modify for the purposes of deciding which -- databases to use, because ordering is important. @@ -839,13 +1163,16 @@ checkConsistency my_flags = do let pkgs = allPackagesInStack db_stack checkPackage p = do - (_,es) <- runValidate $ checkPackageConfig p db_stack False True + (_,es,ws) <- runValidate $ checkPackageConfig p db_stack False True if null es - then return [] + then do when (not simple_output) $ do + _ <- reportValidateErrors [] ws "" Nothing + return () + return [] else do when (not simple_output) $ do reportError ("There are problems in package " ++ display (sourcePackageId p) ++ ":") - _ <- reportValidateErrors es " " Nothing + _ <- reportValidateErrors es ws " " Nothing return () return [p] @@ -912,15 +1239,15 @@ convertPackageInfoIn where convert = fromJust . simpleParse writeNewConfig :: Verbosity -> FilePath -> [InstalledPackageInfo] -> IO () -writeNewConfig verbosity filename packages = do +writeNewConfig verbosity filename ipis = do when (verbosity >= Normal) $ hPutStr stdout "Writing new package config file... " createDirectoryIfMissing True $ takeDirectory filename let shown = concat $ intersperse ",\n " - $ map (show . convertPackageInfoOut) packages + $ map (show . convertPackageInfoOut) ipis fileContents = "[" ++ shown ++ "\n]" - writeFileAtomic filename fileContents - `catch` \e -> + writeFileUtf8Atomic filename fileContents + `catchIO` \e -> if isPermissionError e then die (filename ++ ": you don't have permission to modify this file") else ioError e @@ -931,26 +1258,32 @@ writeNewConfig verbosity filename packages = do -- Sanity-check a new package config, and automatically build GHCi libs -- if requested. -type ValidateError = (Force,String) +type ValidateError = (Force,String) +type ValidateWarning = String -newtype Validate a = V { runValidate :: IO (a, [ValidateError]) } +newtype Validate a = V { runValidate :: IO (a, [ValidateError],[ValidateWarning]) } instance Monad Validate where - return a = V $ return (a, []) + return a = V $ return (a, [], []) m >>= k = V $ do - (a, es) <- runValidate m - (b, es') <- runValidate (k a) - return (b,es++es') + (a, es, ws) <- runValidate m + (b, es', ws') <- runValidate (k a) + return (b,es++es',ws++ws') verror :: Force -> String -> Validate () -verror f s = V (return ((),[(f,s)])) +verror f s = V (return ((),[(f,s)],[])) + +vwarn :: String -> Validate () +vwarn s = V (return ((),[],["Warning: " ++ s])) liftIO :: IO a -> Validate a -liftIO k = V (k >>= \a -> return (a,[])) +liftIO k = V (k >>= \a -> return (a,[],[])) -- returns False if we should die -reportValidateErrors :: [ValidateError] -> String -> Maybe Force -> IO Bool -reportValidateErrors es prefix mb_force = do +reportValidateErrors :: [ValidateError] -> [ValidateWarning] + -> String -> Maybe Force -> IO Bool +reportValidateErrors es ws prefix mb_force = do + mapM_ (warn . (prefix++)) ws oks <- mapM report es return (and oks) where @@ -976,8 +1309,8 @@ validatePackageConfig :: InstalledPackageInfo -> Force -> IO () validatePackageConfig pkg db_stack auto_ghci_libs update force = do - (_,es) <- runValidate $ checkPackageConfig pkg db_stack auto_ghci_libs update - ok <- reportValidateErrors es (display (sourcePackageId pkg) ++ ": ") (Just force) + (_,es,ws) <- runValidate $ checkPackageConfig pkg db_stack auto_ghci_libs update + ok <- reportValidateErrors es ws (display (sourcePackageId pkg) ++ ": ") (Just force) when (not ok) $ exitWith (ExitFailure 1) checkPackageConfig :: InstalledPackageInfo @@ -991,9 +1324,12 @@ checkPackageConfig pkg db_stack auto_ghci_libs update = do checkDuplicates db_stack pkg update mapM_ (checkDep db_stack) (depends pkg) checkDuplicateDepends (depends pkg) - mapM_ (checkDir "import-dirs") (importDirs pkg) - mapM_ (checkDir "library-dirs") (libraryDirs pkg) - mapM_ (checkDir "include-dirs") (includeDirs pkg) + mapM_ (checkDir False "import-dirs") (importDirs pkg) + mapM_ (checkDir True "library-dirs") (libraryDirs pkg) + mapM_ (checkDir True "include-dirs") (includeDirs pkg) + mapM_ (checkDir True "framework-dirs") (frameworkDirs pkg) + mapM_ (checkFile True "haddock-interfaces") (haddockInterfaces pkg) + mapM_ (checkDirURL True "haddock-html") (haddockHTMLs pkg) checkModules pkg mapM_ (checkHSLib (libraryDirs pkg) auto_ghci_libs) (hsLibraries pkg) -- ToDo: check these somehow? @@ -1028,7 +1364,7 @@ checkDuplicates :: PackageDBStack -> InstalledPackageInfo -> Bool -> Validate () checkDuplicates db_stack pkg update = do let pkgid = sourcePackageId pkg - (_top_db_name, pkgs) : _ = db_stack + pkgs = packages (head db_stack) -- -- Check whether this package id already exists in this DB -- @@ -1045,16 +1381,38 @@ checkDuplicates db_stack pkg update = do "Package " ++ display pkgid ++ " overlaps with: " ++ unwords (map display dups) - -checkDir :: String -> String -> Validate () -checkDir thisfield d - | "$topdir" `isPrefixOf` d = return () - | "$httptopdir" `isPrefixOf` d = return () - -- can't check these, because we don't know what $(http)topdir is +checkDir, checkFile, checkDirURL :: Bool -> String -> FilePath -> Validate () +checkDir = checkPath False True +checkFile = checkPath False False +checkDirURL = checkPath True True + +checkPath :: Bool -> Bool -> Bool -> String -> FilePath -> Validate () +checkPath url_ok is_dir warn_only thisfield d + | url_ok && ("http://" `isPrefixOf` d + || "https://" `isPrefixOf` d) = return () + + | url_ok + , Just d' <- stripPrefix "file://" d + = checkPath False is_dir warn_only thisfield d' + + -- Note: we don't check for $topdir/${pkgroot} here. We rely on these + -- variables having been expanded already, see mungePackagePaths. + + | isRelative d = verror ForceFiles $ + thisfield ++ ": " ++ d ++ " is a relative path which " + ++ "makes no sense (as there is nothing for it to be " + ++ "relative to). You can make paths relative to the " + ++ "package database itself by using ${pkgroot}." + -- relative paths don't make any sense; #4134 | otherwise = do - there <- liftIO $ doesDirectoryExist d + there <- liftIO $ if is_dir then doesDirectoryExist d else doesFileExist d when (not there) $ - verror ForceFiles (thisfield ++ ": " ++ d ++ " doesn't exist or isn't a directory") + let msg = thisfield ++ ": " ++ d ++ " doesn't exist or isn't a " + ++ if is_dir then "directory" else "file" + in + if warn_only + then vwarn msg + else verror ForceFiles msg checkDep :: PackageDBStack -> InstalledPackageId -> Validate () checkDep db_stack pkgid @@ -1080,7 +1438,7 @@ checkHSLib dirs auto_ghci_libs lib = do case m of Nothing -> verror ForceFiles ("cannot find " ++ batch_lib_file ++ " on library path") - Just dir -> liftIO $ checkGHCiLib dirs dir batch_lib_file lib auto_ghci_libs + Just dir -> liftIO $ checkGHCiLib dir batch_lib_file lib auto_ghci_libs doesFileExistOnPath :: String -> [FilePath] -> IO (Maybe FilePath) doesFileExistOnPath file path = go path @@ -1089,10 +1447,7 @@ doesFileExistOnPath file path = go path if b then return (Just p) else go ps doesFileExistIn :: String -> String -> IO Bool -doesFileExistIn lib d - | "$topdir" `isPrefixOf` d = return True - | "$httptopdir" `isPrefixOf` d = return True - | otherwise = doesFileExist (d lib) +doesFileExistIn lib d = doesFileExist (d lib) checkModules :: InstalledPackageInfo -> Validate () checkModules pkg = do @@ -1106,13 +1461,10 @@ checkModules pkg = do when (isNothing m) $ verror ForceFiles ("file " ++ file ++ " is missing") -checkGHCiLib :: [String] -> String -> String -> String -> Bool -> IO () -checkGHCiLib dirs batch_lib_dir batch_lib_file lib auto_build +checkGHCiLib :: String -> String -> String -> Bool -> IO () +checkGHCiLib batch_lib_dir batch_lib_file lib auto_build | auto_build = autoBuildGHCiLib batch_lib_dir batch_lib_file ghci_lib_file - | otherwise = do - m <- doesFileExistOnPath ghci_lib_file dirs - when (isNothing m && ghci_lib_file /= "HSrts.o") $ - hPutStrLn stderr ("warning: can't find GHCi lib " ++ ghci_lib_file) + | otherwise = return () where ghci_lib_file = lib <.> "o" @@ -1146,7 +1498,7 @@ findModules paths = return (concat mms) searchDir path prefix = do - fs <- getDirectoryEntries path `catch` \_ -> return [] + fs <- getDirectoryEntries path `catchIO` \_ -> return [] searchEntries path prefix fs searchEntries path prefix [] = return [] @@ -1188,8 +1540,10 @@ expandEnvVars str0 force = go str0 "" = go str (c:acc) lookupEnvVar :: String -> IO String + lookupEnvVar "pkgroot" = return "${pkgroot}" -- these two are special, + lookupEnvVar "pkgrooturl" = return "${pkgrooturl}" -- we don't expand them lookupEnvVar nm = - catch (System.Environment.getEnv nm) + catchIO (System.Environment.getEnv nm) (\ _ -> do dieOrForceAll force ("Unable to expand variable " ++ show nm) return "") @@ -1219,6 +1573,9 @@ dieOrForceAll :: Force -> String -> IO () dieOrForceAll ForceAll s = ignoreError s dieOrForceAll _other s = dieForcible s +warn :: String -> IO () +warn = reportError + ignoreError :: String -> IO () ignoreError s = reportError (s ++ " (ignoring)") @@ -1256,16 +1613,17 @@ getExecDir cmd = removeCmdSuffix = return . Just . initN (length cmd) . unDosifyPath getExecPath :: IO (Maybe String) -getExecPath = - allocaArray len $ \buf -> do - ret <- getModuleFileName nullPtr buf len - if ret == 0 then return Nothing - else liftM Just $ peekCString buf - where len = 2048 -- Plenty, PATH_MAX is 512 under Win32. - -foreign import stdcall unsafe "GetModuleFileNameA" - getModuleFileName :: Ptr () -> CString -> Int -> IO Int32 - +getExecPath = try_size 2048 -- plenty, PATH_MAX is 512 under Win32. + where + try_size size = allocaArray (fromIntegral size) $ \buf -> do + ret <- c_GetModuleFileName nullPtr buf size + case ret of + 0 -> return Nothing + _ | ret < size -> fmap Just $ peekCWString buf + | otherwise -> try_size (size * 2) + +foreign import stdcall unsafe "windows.h GetModuleFileNameW" + c_GetModuleFileName :: Ptr () -> CWString -> Word32 -> IO Word32 #else getLibDir :: IO (Maybe String) getLibDir = return Nothing @@ -1285,7 +1643,7 @@ installSignalHandlers = do _ <- installHandler sigQUIT (Catch interrupt) Nothing _ <- installHandler sigINT (Catch interrupt) Nothing return () -#elif __GLASGOW_HASKELL__ >= 603 +#else -- GHC 6.3+ has support for console events on Windows -- NOTE: running GHCi under a bash shell for some reason requires -- you to press Ctrl-Break rather than Ctrl-C to provoke @@ -1297,34 +1655,41 @@ installSignalHandlers = do _ <- installHandler (Catch sig_handler) return () -#else - return () -- nothing -#endif - -#if __GLASGOW_HASKELL__ <= 604 -isInfixOf :: (Eq a) => [a] -> [a] -> Bool -isInfixOf needle haystack = any (isPrefixOf needle) (tails haystack) #endif #if mingw32_HOST_OS || mingw32_TARGET_OS throwIOIO :: Exception.IOException -> IO a throwIOIO = Exception.throwIO +#endif catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a catchIO = Exception.catch -#endif catchError :: IO a -> (String -> IO a) -> IO a catchError io handler = io `Exception.catch` handler' where handler' (Exception.ErrorCall err) = handler err +tryIO :: IO a -> IO (Either Exception.IOException a) +tryIO = Exception.try + +writeBinaryFileAtomic :: Bin.Binary a => FilePath -> a -> IO () +writeBinaryFileAtomic targetFile obj = + withFileAtomic targetFile $ \h -> do + hSetBinaryMode h True + B.hPutStr h (Bin.encode obj) + +writeFileUtf8Atomic :: FilePath -> String -> IO () +writeFileUtf8Atomic targetFile content = + withFileAtomic targetFile $ \h -> do + hSetEncoding h utf8 + hPutStr h content -- copied from Cabal's Distribution.Simple.Utils, except that we want -- to use text files here, rather than binary files. -writeFileAtomic :: FilePath -> String -> IO () -writeFileAtomic targetFile content = do +withFileAtomic :: FilePath -> (Handle -> IO ()) -> IO () +withFileAtomic targetFile write_content = do (newFile, newHandle) <- openNewFile targetDir template - do hPutStr newHandle content + do write_content newHandle hClose newHandle #if mingw32_HOST_OS || mingw32_TARGET_OS renameFile newFile targetFile @@ -1332,7 +1697,7 @@ writeFileAtomic targetFile content = do `catchIO` \err -> do exists <- doesFileExist targetFile if exists - then do removeFile targetFile + then do removeFileSafe targetFile -- Big fat hairy race condition renameFile newFile targetFile -- If the removeFile succeeds and the renameFile fails @@ -1342,7 +1707,7 @@ writeFileAtomic targetFile content = do renameFile newFile targetFile #endif `Exception.onException` do hClose newHandle - removeFile newFile + removeFileSafe newFile where template = targetName <.> "tmp" targetDir | null targetDir_ = "." @@ -1351,66 +1716,12 @@ writeFileAtomic targetFile content = do -- to always return a valid dir (targetDir_,targetName) = splitFileName targetFile --- Ugh, this is a copy/paste of code from the base library, but --- if uses 666 rather than 600 for the permissions. openNewFile :: FilePath -> String -> IO (FilePath, Handle) openNewFile dir template = do - pid <- c_getpid - findTempName pid - where - -- We split off the last extension, so we can use .foo.ext files - -- for temporary files (hidden on Unix OSes). Unfortunately we're - -- below filepath in the hierarchy here. - (prefix,suffix) = - case break (== '.') $ reverse template of - -- First case: template contains no '.'s. Just re-reverse it. - (rev_suffix, "") -> (reverse rev_suffix, "") - -- Second case: template contains at least one '.'. Strip the - -- dot from the prefix and prepend it to the suffix (if we don't - -- do this, the unique number will get added after the '.' and - -- thus be part of the extension, which is wrong.) - (rev_suffix, '.':rest) -> (reverse rest, '.':reverse rev_suffix) - -- Otherwise, something is wrong, because (break (== '.')) should - -- always return a pair with either the empty string or a string - -- beginning with '.' as the second component. - _ -> error "bug in System.IO.openTempFile" - - oflags = rw_flags .|. o_EXCL - -#if __GLASGOW_HASKELL__ < 611 - withFilePath = withCString -#endif - - findTempName x = do - fd <- withFilePath filepath $ \ f -> - c_open f oflags 0o666 - if fd < 0 - then do - errno <- getErrno - if errno == eEXIST - then findTempName (x+1) - else ioError (errnoToIOError "openNewBinaryFile" errno Nothing (Just dir)) - else do - -- XXX We want to tell fdToHandle what the filepath is, - -- as any exceptions etc will only be able to report the - -- fd currently - h <- -#if __GLASGOW_HASKELL__ >= 609 - fdToHandle fd -#else - fdToHandle (fromIntegral fd) -#endif - `Exception.onException` c_close fd - return (filepath, h) - where - filename = prefix ++ show x ++ suffix - filepath = dir `combine` filename - --- XXX Copied from GHC.Handle -std_flags, output_flags, rw_flags :: CInt -std_flags = o_NONBLOCK .|. o_NOCTTY -output_flags = std_flags .|. o_CREAT -rw_flags = output_flags .|. o_RDWR + -- this was added to System.IO in 6.12.1 + -- we must use this version because the version below opens the file + -- in binary mode. + openTempFileWithDefaultPermissions dir template -- | The function splits the given string to substrings -- using 'isSearchPathSeparator'. @@ -1431,3 +1742,19 @@ parseSearchPath path = split path _ -> chunk' (chunk', rest') = break isSearchPathSeparator s + +readUTF8File :: FilePath -> IO String +readUTF8File file = do + h <- openFile file ReadMode + -- fix the encoding to UTF-8 + hSetEncoding h utf8 + hGetContents h + +-- removeFileSave doesn't throw an exceptions, if the file is already deleted +removeFileSafe :: FilePath -> IO () +removeFileSafe fn = + removeFile fn `catchIO` \ e -> + when (not $ isDoesNotExistError e) $ ioError e + +absolutePath :: FilePath -> IO FilePath +absolutePath path = return . normalise . ( path) =<< getCurrentDirectory