From 34b0bd51383120fe9a2da21d5c0af3c9a662e598 Mon Sep 17 00:00:00 2001
From: Ian Lynagh <igloo@earth.li>
Date: Sat, 29 Jul 2006 19:29:46 +0000
Subject: [PATCH] Refactor ghc-pkg This patch fixes a couple of issues with
 the     Be lazier in user config creation, and don't fail
 on missing configs. patch. It puts the
 createDirectoryIfMissing back in and removes assumptions
 that the package.conf file already exists.

---
 utils/ghc-pkg/Main.hs |   69 +++++++++++++++++++++++--------------------------
 1 file changed, 33 insertions(+), 36 deletions(-)

diff --git a/utils/ghc-pkg/Main.hs b/utils/ghc-pkg/Main.hs
index b2f7d18..cc634ea 100644
--- a/utils/ghc-pkg/Main.hs
+++ b/utils/ghc-pkg/Main.hs
@@ -64,6 +64,8 @@ import CString
 #endif
 #endif
 
+import IO ( isPermissionError, isDoesNotExistError )
+
 -- -----------------------------------------------------------------------------
 -- Entry point
 
@@ -383,7 +385,6 @@ registerPackage input defines flags auto_ghci_libs update force = do
 	db_to_operate_on = my_head "db" db_stack
 	db_filename	 = fst db_to_operate_on
   --
-  checkConfigAccess db_filename
 
   s <-
     case input of
@@ -403,8 +404,7 @@ registerPackage input defines flags auto_ghci_libs update force = do
   validatePackageConfig pkg db_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
-  savePackageConfig db_filename
-  maybeRestoreOldConfig db_filename $
+  savingOldConfig db_filename $
     writeNewConfig db_filename new_details
 
 parsePackageInfo
@@ -437,15 +437,13 @@ modifyPackage
 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
 
 -- -----------------------------------------------------------------------------
@@ -566,49 +564,43 @@ strList = show
 -- -----------------------------------------------------------------------------
 -- 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 = 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
@@ -1012,6 +1004,11 @@ pathSeparator = '\\'
 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]
-- 
1.7.10.4