| FlagSimpleOutput
| FlagNamesOnly
| FlagIgnoreCase
+ | FlagNoUserDb
deriving Eq
flags :: [OptDescr Flag]
"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)
, 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 ex ->
+ 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")
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
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.
handler' e = Exception.throw e
#endif
+throwIOIO :: Exception.IOException -> IO a
+#if __GLASGOW_HASKELL__ >= 609
+throwIOIO = Exception.throwIO
+#else
+throwIOIO ioe = Exception.throwIO (Exception.IOException ioe)
+#endif
+
catchError :: IO a -> (String -> IO a) -> IO a
#if __GLASGOW_HASKELL__ >= 609
catchError io handler = io `Exception.catch` handler'
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
+ (tmpFile, tmpHandle) <- openTempFile targetDir template
+ do hPutStr tmpHandle content
+ hClose tmpHandle
+#if mingw32_HOST_OS || mingw32_TARGET_OS
+ renameFile tmpFile 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 tmpFile targetFile
+ -- If the removeFile succeeds and the renameFile fails
+ -- then we've lost the atomic property.
+ else throwIOIO err
+#else
+ renameFile tmpFile targetFile
+#endif
+ `onException` do hClose tmpHandle
+ removeFile tmpFile
+ 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
projects / ghc-hetmet.git / blobdiff