X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=utils%2Fghc-pkg%2FMain.hs;h=344a21edb89cd5278db8146a3496b270e5b1acfe;hb=e5e6f6a16796cba5e2b6bd376481cf2cd0ba9734;hp=86fd652e13c334dc932a655c087c6b18527c42f5;hpb=0eab1ca5b1eb7b15085ee5fe621a842f5bc57f1f;p=ghc-hetmet.git diff --git a/utils/ghc-pkg/Main.hs b/utils/ghc-pkg/Main.hs index 86fd652..344a21e 100644 --- a/utils/ghc-pkg/Main.hs +++ b/utils/ghc-pkg/Main.hs @@ -43,24 +43,20 @@ import System.Exit ( exitWith, ExitCode(..) ) import System.Environment ( getArgs, getProgName, getEnv ) import System.IO import System.IO.Error (try) -import Data.List ( isPrefixOf, isSuffixOf, intersperse, sortBy, nub, - unfoldr, break, partition ) -#if __GLASGOW_HASKELL__ > 604 -import Data.List ( isInfixOf ) -#else -import Data.List ( tails ) -#endif +import Data.List import Control.Concurrent -#ifdef mingw32_HOST_OS import Foreign -import Foreign.C.String +import Foreign.C +#ifdef mingw32_HOST_OS import GHC.ConsoleHandler #else -import System.Posix +import System.Posix hiding (fdToHandle) #endif -import IO ( isPermissionError, isDoesNotExistError ) +import IO ( isPermissionError ) +import System.Posix.Internals +import GHC.Handle (fdToHandle) #if defined(GLOB) import System.Process(runInteractiveCommand) @@ -102,6 +98,7 @@ data Flag | FlagSimpleOutput | FlagNamesOnly | FlagIgnoreCase + | FlagNoUserDb deriving Eq flags :: [OptDescr Flag] @@ -114,6 +111,8 @@ flags = [ "use the specified package config file", Option [] ["global-conf"] (ReqArg FlagGlobalConfig "FILE") "location of the global package config", + Option [] ["no-user-package-conf"] (NoArg FlagNoUserDb) + "never read the user package database", Option [] ["force"] (NoArg FlagForce) "ignore missing dependencies, directories, and libraries", Option [] ["force-files"] (NoArg FlagForceFiles) @@ -356,14 +355,15 @@ globVersion = Version{ versionBranch=[], versionTags=["*"] } type PackageDBName = FilePath type PackageDB = [InstalledPackageInfo] -type PackageDBStack = [(PackageDBName,PackageDB)] +type NamedPackageDB = (PackageDBName, PackageDB) +type PackageDBStack = [NamedPackageDB] -- A stack of package databases. Convention: head is the topmost -- in the stack. Earlier entries override later one. allPackagesInStack :: PackageDBStack -> [InstalledPackageInfo] allPackagesInStack = concatMap snd -getPkgDatabases :: Bool -> [Flag] -> IO PackageDBStack +getPkgDatabases :: Bool -> [Flag] -> IO (PackageDBStack, Maybe PackageDBName) getPkgDatabases modify 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 @@ -397,19 +397,28 @@ getPkgDatabases modify my_flags = do , isSuffixOf ".conf" file] else return [] - -- get the location of the user package database, and create it if necessary - appdir <- getAppUserDataDirectory "ghc" + let no_user_db = FlagNoUserDb `elem` my_flags - let - subdir = targetARCH ++ '-':targetOS ++ '-':Version.version - archdir = appdir subdir - user_conf = archdir "package.conf" - user_exists <- doesFileExist user_conf + -- 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" + + 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 -- 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 - | modify || user_exists = user_conf : global_confs ++ [global_conf] + | Just (user_conf,user_exists) <- mb_user_conf, + modify || user_exists = user_conf : global_confs ++ [global_conf] | otherwise = global_confs ++ [global_conf] e_pkg_path <- try (System.Environment.getEnv "GHC_PACKAGE_PATH") @@ -419,26 +428,28 @@ getPkgDatabases modify my_flags = do Right path | last cs == "" -> init cs ++ sys_databases | otherwise -> cs - where cs = splitSearchPath path + where cs = parseSearchPath path -- The "global" database is always the one at the bottom of the stack. -- This is the database we modify by default. virt_global_conf = last env_stack let db_flags = [ f | Just f <- map is_db_flag my_flags ] - where is_db_flag FlagUser = Just user_conf + where is_db_flag FlagUser + | Just (user_conf, _user_exists) <- mb_user_conf + = Just user_conf is_db_flag FlagGlobal = Just virt_global_conf is_db_flag (FlagConfig f) = Just f is_db_flag _ = Nothing - final_stack <- + (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 - else return (reverse (nub db_flags)) + 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 @@ -452,16 +463,16 @@ getPkgDatabases modify my_flags = do [ f | FlagConfig f <- reverse my_flags ] ++ env_stack - modifying f - | f `elem` flag_stack = return (dropWhile (/= f) flag_stack) - | otherwise = die ("requesting modification of database:\n\t" ++ f ++ "\n\twhich is not in the database 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 - if null db_flags - then modifying virt_global_conf - else modifying (head db_flags) + return (flag_stack, to_modify) db_stack <- mapM readParseDatabase final_stack - return db_stack + return (db_stack, to_modify) readParseDatabase :: PackageDBName -> IO (PackageDBName,PackageDB) readParseDatabase filename = do @@ -485,12 +496,11 @@ registerPackage :: FilePath -> Force -> IO () registerPackage input my_flags auto_ghci_libs update force = do - db_stack <- getPkgDatabases True my_flags + (db_stack, Just to_modify) <- getPkgDatabases True my_flags let - db_to_operate_on = my_head "db" db_stack - db_filename = fst db_to_operate_on + db_to_operate_on = my_head "register" $ + filter ((== to_modify).fst) db_stack -- - s <- case input of "-" -> do @@ -505,10 +515,13 @@ registerPackage input my_flags auto_ghci_libs update force = do pkg <- parsePackageInfo expanded putStrLn "done." - validatePackageConfig pkg db_stack auto_ghci_libs update force + let truncated_stack = dropWhile ((/= to_modify).fst) 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 = package p /= package pkg - writeNewConfig db_filename new_details + writeNewConfig to_modify new_details parsePackageInfo :: String @@ -539,19 +552,25 @@ modifyPackage -> Force -> IO () modifyPackage fn pkgid my_flags force = do - db_stack <- getPkgDatabases True{-modify-} my_flags - let old_broken = brokenPackages (allPackagesInStack db_stack) - let ((db_name, pkgs) : rest_of_stack) = db_stack - ps <- findPackages [(db_name,pkgs)] (Id pkgid) - let pids = map package ps - let new_config = concat (map modify pkgs) + (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) + let + pids = map package ps modify pkg | package pkg `elem` pids = fn pkg | otherwise = [pkg] - let new_stack = (db_name,new_config) : rest_of_stack + new_config = concat (map modify pkgs) + + let + 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 new_broken = map package (brokenPackages (allPackagesInStack new_stack)) newly_broken = filter (`notElem` map package old_broken) new_broken - + -- when (not (null newly_broken)) $ dieOrForceAll force ("unregistering " ++ display pkgid ++ " would break the following packages: " @@ -565,7 +584,7 @@ modifyPackage fn pkgid my_flags force = do listPackages :: [Flag] -> Maybe PackageArg -> Maybe (String->Bool) -> IO () listPackages my_flags mPackageName mModuleName = do let simple_output = FlagSimpleOutput `elem` my_flags - db_stack <- getPkgDatabases False my_flags + (db_stack, _) <- getPkgDatabases False 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)) @@ -617,7 +636,7 @@ listPackages my_flags mPackageName mModuleName = do latestPackage :: [Flag] -> PackageIdentifier -> IO () latestPackage my_flags pkgid = do - db_stack <- getPkgDatabases False my_flags + (db_stack, _) <- getPkgDatabases False my_flags ps <- findPackages db_stack (Id pkgid) show_pkg (sortBy compPkgIdVer (map package ps)) where @@ -629,13 +648,13 @@ latestPackage my_flags pkgid = do describePackage :: [Flag] -> PackageArg -> IO () describePackage my_flags pkgarg = do - db_stack <- getPkgDatabases False my_flags + (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 + (db_stack, _) <- getPkgDatabases False my_flags doDump (allPackagesInStack db_stack) doDump :: [InstalledPackageInfo] -> IO () @@ -644,13 +663,20 @@ doDump = mapM_ putStrLn . intersperse "---" . map showInstalledPackageInfo -- PackageId is can have globVersion for the version findPackages :: PackageDBStack -> PackageArg -> IO [InstalledPackageInfo] findPackages db_stack pkgarg - = case [ p | p <- all_pkgs, pkgarg `matchesPkg` p ] of - [] -> dieWith 2 ("cannot find package " ++ pkg_msg pkgarg) + = fmap (concatMap snd) $ findPackagesByDB db_stack pkgarg + +findPackagesByDB :: PackageDBStack -> PackageArg + -> IO [(NamedPackageDB, [InstalledPackageInfo])] +findPackagesByDB db_stack pkgarg + = case [ (db, matched) + | db@(_, pkgs) <- db_stack, + let matched = filter (pkgarg `matchesPkg`) pkgs, + not (null matched) ] of + [] -> die ("cannot find package " ++ pkg_msg pkgarg) ps -> return ps where - all_pkgs = allPackagesInStack db_stack pkg_msg (Id pkgid) = display pkgid - pkg_msg (Substring pkgpat _) = "matching "++pkgpat + pkg_msg (Substring pkgpat _) = "matching " ++ pkgpat matches :: PackageIdentifier -> PackageIdentifier -> Bool pid `matches` pid' @@ -669,7 +695,7 @@ compPkgIdVer p1 p2 = pkgVersion p1 `compare` pkgVersion p2 describeField :: [Flag] -> PackageArg -> [String] -> IO () describeField my_flags pkgarg fields = do - db_stack <- getPkgDatabases False my_flags + (db_stack, _) <- getPkgDatabases False my_flags fns <- toFields fields ps <- findPackages db_stack pkgarg let top_dir = takeDirectory (fst (last db_stack)) @@ -735,7 +761,7 @@ strList = show checkConsistency :: [Flag] -> IO () checkConsistency my_flags = do - db_stack <- getPkgDatabases True my_flags + (db_stack, _) <- getPkgDatabases True my_flags -- check behaves like modify for the purposes of deciding which -- databases to use, because ordering is important. let pkgs = allPackagesInStack db_stack @@ -760,8 +786,8 @@ brokenPackages pkgs = go [] pkgs where go avail not_avail = case partition (depsAvailable avail) not_avail of - ([], not_avail) -> not_avail - (new_avail, not_avail) -> go (new_avail ++ avail) not_avail + ([], not_avail') -> not_avail' + (new_avail, not_avail') -> go (new_avail ++ avail) not_avail' depsAvailable :: [InstalledPackageInfo] -> InstalledPackageInfo -> Bool @@ -796,46 +822,16 @@ writeNewConfig :: FilePath -> [InstalledPackageInfo] -> IO () writeNewConfig filename packages = do hPutStr stdout "Writing new package config file... " createDirectoryIfMissing True $ takeDirectory filename - h <- openFile filename WriteMode `catch` \e -> - if isPermissionError e - then die (filename ++ ": you don't have permission to modify this file") - else ioError e let shown = concat $ intersperse ",\n " $ map (show . convertPackageInfoOut) packages fileContents = "[" ++ shown ++ "\n]" - hPutStrLn h fileContents - hClose h + writeFileAtomic filename fileContents + `catch` \e -> + if isPermissionError e + then die (filename ++ ": you don't have permission to modify this file") + else ioError e hPutStrLn stdout "done." -savingOldConfig :: FilePath -> IO () -> IO () -savingOldConfig filename io = Exception.block $ do - hPutStr stdout "Saving old package config file... " - -- mv rather than cp because we've already done an hGetContents - -- on this file so we won't be able to open it for writing - -- unless we move the old one out of the way... - let oldFile = filename ++ ".old" - restore_on_error <- catch (renameFile filename oldFile >> return True) $ - \err -> do - unless (isDoesNotExistError err) $ do - hPutStrLn stderr (unwords ["Unable to rename", show filename, - "to", show oldFile]) - ioError err - return False - (do hPutStrLn stdout "done."; io) - `onException` do - hPutStr stdout ("WARNING: an error was encountered while writing " - ++ "the new configuration.\n") - -- remove any partially complete new version: - removeFile filename `catchIO` \_ -> return () - -- and attempt to restore the old one, if we had one: - when restore_on_error $ do - hPutStr stdout "Attempting to restore the old configuration... " - do renameFile oldFile filename - hPutStrLn stdout "done." - `catchIO` \err -> hPutStrLn stdout ("Failed: " ++ show err) - -- Note the above renameFile sometimes fails on Windows with - -- "permission denied", I have no idea why --SDM. - ----------------------------------------------------------------------------- -- Sanity-check a new package config, and automatically build GHCi libs -- if requested. @@ -850,6 +846,7 @@ validatePackageConfig pkg db_stack auto_ghci_libs update force = do checkPackageId pkg checkDuplicates db_stack pkg update force mapM_ (checkDep db_stack force) (depends pkg) + checkDuplicateDepends force (depends pkg) mapM_ (checkDir force) (importDirs pkg) mapM_ (checkDir force) (libraryDirs pkg) mapM_ (checkDir force) (includeDirs pkg) @@ -917,6 +914,14 @@ checkDep db_stack force pkgid all_pkgs = allPackagesInStack db_stack pkgids = map package all_pkgs +checkDuplicateDepends :: Force -> [PackageIdentifier] -> IO () +checkDuplicateDepends force deps + | null dups = return () + | otherwise = dieOrForceAll force ("package has duplicate dependencies: " ++ + unwords (map display dups)) + where + dups = [ p | (p:_:_) <- group (sort deps) ] + realVersion :: PackageIdentifier -> Bool realVersion pkgid = versionBranch (pkgVersion pkgid) /= [] @@ -1139,6 +1144,15 @@ catchIO io handler = io `Exception.catch` handler' handler' e = Exception.throw e #endif +#if mingw32_HOST_OS || mingw32_TARGET_OS +throwIOIO :: Exception.IOException -> IO a +#if __GLASGOW_HASKELL__ >= 609 +throwIOIO = Exception.throwIO +#else +throwIOIO ioe = Exception.throwIO (Exception.IOException ioe) +#endif +#endif + catchError :: IO a -> (String -> IO a) -> IO a #if __GLASGOW_HASKELL__ >= 609 catchError io handler = io `Exception.catch` handler' @@ -1149,7 +1163,7 @@ catchError io handler = io `Exception.catch` handler' handler' e = Exception.throw e #endif -onException :: IO a -> IO () -> IO a +onException :: IO a -> IO b -> IO a #if __GLASGOW_HASKELL__ >= 609 onException = Exception.onException #else @@ -1157,3 +1171,112 @@ onException io what = io `Exception.catch` \e -> do what Exception.throw e #endif + +-- 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 + (newFile, newHandle) <- openNewFile targetDir template + do hPutStr newHandle content + hClose newHandle +#if mingw32_HOST_OS || mingw32_TARGET_OS + renameFile newFile targetFile + -- If the targetFile exists then renameFile will fail + `catchIO` \err -> do + exists <- doesFileExist targetFile + if exists + then do removeFile targetFile + -- Big fat hairy race condition + renameFile newFile targetFile + -- If the removeFile succeeds and the renameFile fails + -- then we've lost the atomic property. + else throwIOIO err +#else + renameFile newFile targetFile +#endif + `onException` do hClose newHandle + removeFile newFile + where + template = targetName <.> "tmp" + targetDir | null targetDir_ = "." + | otherwise = targetDir_ + --TODO: remove this when takeDirectory/splitFileName is fixed + -- 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 + + findTempName x = do + fd <- withCString 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 + `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 + +-- | The function splits the given string to substrings +-- using 'isSearchPathSeparator'. +parseSearchPath :: String -> [FilePath] +parseSearchPath path = split path + where + split :: String -> [String] + split s = + case rest' of + [] -> [chunk] + _:rest -> chunk : split rest + where + chunk = + case chunk' of +#ifdef mingw32_HOST_OS + ('\"':xs@(_:_)) | last xs == '\"' -> init xs +#endif + _ -> chunk' + + (chunk', rest') = break isSearchPathSeparator s