#endif
#endif
+import IO ( isPermissionError, isDoesNotExistError )
+
-- -----------------------------------------------------------------------------
-- Entry point
| FlagConfig FilePath
| FlagGlobalConfig FilePath
| FlagForce
+ | FlagForceFiles
| FlagAutoGHCiLibs
| FlagDefinedName String String
| FlagSimpleOutput
"location of the global package config",
Option [] ["force"] (NoArg FlagForce)
"ignore missing dependencies, directories, and libraries",
+ Option [] ["force-files"] (NoArg FlagForceFiles)
+ "ignore missing directories and libraries only",
Option ['g'] ["auto-ghci-libs"] (NoArg FlagAutoGHCiLibs)
"automatically build libs for GHCi (with register)",
Option ['?'] ["help"] (NoArg FlagHelp)
-- -----------------------------------------------------------------------------
-- Do the business
+data Force = ForceAll | ForceFiles | NoForce
+
runit :: [Flag] -> [String] -> IO ()
runit cli nonopts = do
prog <- getProgramName
let
- force = FlagForce `elem` cli
+ force
+ | FlagForce `elem` cli = ForceAll
+ | FlagForceFiles `elem` cli = ForceFiles
+ | otherwise = NoForce
auto_ghci_libs = FlagAutoGHCiLibs `elem` cli
defines = [ (nm,val) | FlagDefinedName nm val <- cli ]
--
-> [Flag]
-> Bool -- auto_ghci_libs
-> Bool -- update
- -> Bool -- force
+ -> Force
-> IO ()
registerPackage input defines flags auto_ghci_libs update force = do
db_stack <- getPkgDatabases True flags
db_to_operate_on = my_head "db" db_stack
db_filename = fst db_to_operate_on
--
- checkConfigAccess db_filename
s <-
case input of
expanded <- expandEnvVars s defines force
- pkg0 <- parsePackageInfo expanded defines force
+ pkg0 <- parsePackageInfo expanded defines
putStrLn "done."
let pkg = resolveDeps db_stack pkg0
validatePackageConfig pkg db_stack auto_ghci_libs update force
- let new_details = snd db_to_operate_on ++ [pkg]
- savePackageConfig db_filename
- maybeRestoreOldConfig db_filename $
+ let new_details = filter not_this (snd db_to_operate_on) ++ [pkg]
+ not_this p = package p /= package pkg
+ savingOldConfig db_filename $
writeNewConfig db_filename new_details
parsePackageInfo
:: String
-> [(String,String)]
- -> Bool
-> IO InstalledPackageInfo
-parsePackageInfo str defines force =
+parsePackageInfo str defines =
case parseInstalledPackageInfo str of
ParseOk _warns ok -> return ok
ParseFailed err -> die (showError err)
modifyPackage fn pkgid flags = do
db_stack <- getPkgDatabases True{-modify-} flags
let ((db_name, pkgs) : _) = db_stack
- checkConfigAccess db_name
ps <- findPackages [(db_name,pkgs)] pkgid
let pids = map package ps
- savePackageConfig db_name
let new_config = concat (map modify pkgs)
modify pkg
| package pkg `elem` pids = fn pkg
| otherwise = [pkg]
- maybeRestoreOldConfig db_name $
+ savingOldConfig db_name $
writeNewConfig db_name new_config
-- -----------------------------------------------------------------------------
-- -----------------------------------------------------------------------------
-- Manipulating package.conf files
-checkConfigAccess :: FilePath -> IO ()
-checkConfigAccess filename = do
- access <- getPermissions filename
- when (not (writable access))
- (die (filename ++ ": you don't have permission to modify this file"))
-
-maybeRestoreOldConfig :: FilePath -> IO () -> IO ()
-maybeRestoreOldConfig filename io
- = io `catch` \e -> do
- hPutStrLn stderr (show e)
- hPutStr stdout ("\nWARNING: an error was encountered while the new \n"++
- "configuration was being written. Attempting to \n"++
- "restore the old configuration... ")
- renameFile (filename ++ ".old") filename
- hPutStrLn stdout "done."
- ioError e
-
writeNewConfig :: FilePath -> [InstalledPackageInfo] -> IO ()
writeNewConfig filename packages = do
hPutStr stdout "Writing new package config file... "
- h <- openFile filename WriteMode
+ createDirectoryIfMissing True $ getFilenameDir 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
hPutStrLn h (show packages)
hClose h
hPutStrLn stdout "done."
-savePackageConfig :: FilePath -> IO ()
-savePackageConfig filename = do
+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"
- doesExist <- doesFileExist oldFile `catch` (\ _ -> return False)
- when doesExist (removeFile oldFile `catch` (const $ return ()))
- catch (renameFile filename oldFile)
- (\ err -> do
- hPutStrLn stderr (unwords [ "Unable to rename "
- , show filename
- , " to "
- , show oldFile
- ])
- ioError err)
+ 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
hPutStrLn stdout "done."
+ io `catch` \e -> do
+ hPutStrLn stderr (show e)
+ hPutStr stdout ("\nWARNING: an error was encountered while writing"
+ ++ "the new configuration.\n")
+ when restore_on_error $ do
+ hPutStr stdout "Attempting to restore the old configuration..."
+ do renameFile oldFile filename
+ hPutStrLn stdout "done."
+ `catch` \err -> hPutStrLn stdout ("Failed: " ++ show err)
+ ioError e
-----------------------------------------------------------------------------
-- Sanity-check a new package config, and automatically build GHCi libs
-> PackageDBStack
-> Bool -- auto-ghc-libs
-> Bool -- update
- -> Bool -- force
+ -> Force
-> IO ()
validatePackageConfig pkg db_stack auto_ghci_libs update force = do
checkPackageId pkg
- checkDuplicates db_stack pkg update force
+ checkDuplicates db_stack pkg update
mapM_ (checkDep db_stack force) (depends pkg)
mapM_ (checkDir force) (importDirs pkg)
mapM_ (checkDir force) (libraryDirs pkg)
[] -> dep_pkgid -- No installed package; use
-- the version-less one
-checkDuplicates :: PackageDBStack -> InstalledPackageInfo -> Bool -> Bool
- -> IO ()
-checkDuplicates db_stack pkg update force = do
+checkDuplicates :: PackageDBStack -> InstalledPackageInfo -> Bool -> IO ()
+checkDuplicates db_stack pkg update = do
let
pkgid = package pkg
(_top_db_name, pkgs) : _ = db_stack
-checkDir :: Bool -> String -> IO ()
+checkDir :: Force -> String -> IO ()
checkDir force d
| "$topdir" `isPrefixOf` d = return ()
-- can't check this, because we don't know what $topdir is
| otherwise = do
there <- doesDirectoryExist d
when (not there)
- (dieOrForce force (d ++ " doesn't exist or isn't a directory"))
+ (dieOrForceFile force (d ++ " doesn't exist or isn't a directory"))
-checkDep :: PackageDBStack -> Bool -> PackageIdentifier -> IO ()
+checkDep :: PackageDBStack -> Force -> PackageIdentifier -> IO ()
checkDep db_stack force pkgid
- | not real_version || pkgid `elem` pkgids = return ()
- | otherwise = dieOrForce force ("dependency " ++ showPackageId pkgid
+ | pkgid `elem` pkgids || (not real_version && name_exists) = return ()
+ | otherwise = dieOrForceAll force ("dependency " ++ showPackageId pkgid
++ " doesn't exist")
where
-- for backwards compat, we treat 0.0 as a special version,
-- and don't check that it actually exists.
real_version = realVersion pkgid
+ name_exists = any (\p -> pkgName (package p) == name) all_pkgs
+ name = pkgName pkgid
+
all_pkgs = concat (map snd db_stack)
pkgids = map package all_pkgs
realVersion :: PackageIdentifier -> Bool
realVersion pkgid = versionBranch (pkgVersion pkgid) /= []
-checkHSLib :: [String] -> Bool -> Bool -> String -> IO ()
+checkHSLib :: [String] -> Bool -> Force -> String -> IO ()
checkHSLib dirs auto_ghci_libs force lib = do
let batch_lib_file = "lib" ++ lib ++ ".a"
bs <- mapM (doesLibExistIn batch_lib_file) dirs
case [ dir | (exists,dir) <- zip bs dirs, exists ] of
- [] -> dieOrForce force ("cannot find " ++ batch_lib_file ++
+ [] -> dieOrForceFile force ("cannot find " ++ batch_lib_file ++
" on library path")
(dir:_) -> checkGHCiLib dirs dir batch_lib_file lib auto_ghci_libs
where isAuto OF_AutoGHCiLibs = True; isAuto _ = False
input_file = my_head "inp" ([ f | (OF_Input f) <- clis] ++ ["-"])
- force = OF_Force `elem` clis
+ force = if OF_Force `elem` clis then ForceAll else NoForce
defines = [ (nm,val) | OF_DefinedName nm val <- clis ]
-- ---------------------------------------------------------------------------
-- expanding environment variables in the package configuration
-expandEnvVars :: String -> [(String, String)] -> Bool -> IO String
+expandEnvVars :: String -> [(String, String)] -> Force -> IO String
expandEnvVars str defines force = go str ""
where
go "" acc = return $! reverse acc
Just x | not (null x) -> return x
_ ->
catch (System.getEnv nm)
- (\ _ -> do dieOrForce force ("Unable to expand variable " ++
+ (\ _ -> do dieOrForceAll force ("Unable to expand variable " ++
show nm)
return "")
hPutStrLn stderr (prog ++ ": " ++ s)
exitWith (ExitFailure 1)
-dieOrForce :: Bool -> String -> IO ()
-dieOrForce force s
- | force = do hFlush stdout; hPutStrLn stderr (s ++ " (ignoring)")
- | otherwise = die (s ++ " (use --force to override)")
+dieOrForceAll :: Force -> String -> IO ()
+dieOrForceAll ForceAll s = ignoreError s
+dieOrForceAll _other s = dieForcible s
+
+dieOrForceFile :: Force -> String -> IO ()
+dieOrForceFile ForceAll s = ignoreError s
+dieOrForceFile ForceFiles s = ignoreError s
+dieOrForceFile _other s = dieForcible s
+
+ignoreError :: String -> IO ()
+ignoreError s = do hFlush stdout; hPutStrLn stderr (s ++ " (ignoring)")
+
+dieForcible :: String -> IO ()
+dieForcible s = die (s ++ " (use --force to override)")
-----------------------------------------
-- Cut and pasted from ghc/compiler/SysTools
pathSeparator = '/'
#endif
+getFilenameDir :: FilePath -> FilePath
+getFilenameDir fn = case break isPathSeparator (reverse fn) of
+ (xs, "") -> "."
+ (_, sep:ys) -> reverse ys
+
-- | The function splits the given string to substrings
-- using the 'searchPathSeparator'.
parseSearchPath :: String -> [FilePath]