ghc/utils/ghc-pkg/Main.hs

   1 -----------------------------------------------------------------------------
   2 -- $Id: Main.hs,v 1.7 2001/03/27 13:38:03 simonmar Exp $
   3 --
   4 -- Package management tool
   5 -----------------------------------------------------------------------------
   6
   7 module Main where
   8
   9 import Package
  10
  11 #ifdef __GLASGOW_HASKELL__
  12 import qualified Exception
  13 #endif
  14 import GetOpt
  15 import Pretty
  16 import Monad
  17 import Directory
  18 import System
  19 import IO
  20
  21 main = do
  22   args <- getArgs
  23
  24   case getOpt Permute flags args of
  25         (clis,[],[]) -> runit clis
  26         (_,_,errors) -> die (concat errors ++
  27                              usageInfo usageHeader flags)
  28
  29 data Flag = Config String | List | Add | Remove String
  30 isConfig (Config _) = True
  31 isConfig _ = False
  32
  33 usageHeader = "ghc-pkg [OPTION...]"
  34
  35 flags = [
  36   Option ['f'] ["config-file"] (ReqArg Config "FILE")
  37         "Use the specified package config file",
  38   Option ['l'] ["list-packages"] (NoArg List)
  39         "List the currently installed packages",
  40   Option ['a'] ["add-package"] (NoArg Add)
  41         "Add a new package",
  42   Option ['r'] ["remove-package"] (ReqArg Remove "NAME")
  43         "Remove an installed package"
  44   ]
  45
  46 runit clis = do
  47   conf_file <-
  48      case [ f | Config f <- clis ] of
  49         []  -> die "missing -f option, location of package.conf unknown"
  50         [f] -> return f
  51         _   -> die (usageInfo usageHeader flags)
  52
  53   s <- readFile conf_file
  54   let details = read s :: [PackageConfig]
  55   eval_catch details (\_ -> die "parse error in package config file")
  56
  57   case [ c | c <- clis, not (isConfig c) ] of
  58     [ List ]     -> listPackages details
  59     [ Add  ]     -> addPackage details conf_file
  60     [ Remove p ] -> removePackage details conf_file p
  61     _            -> die (usageInfo usageHeader flags)
  62
  63
  64 listPackages :: [PackageConfig] -> IO ()
  65 listPackages details = do
  66   hPutStr stdout (listPkgs details)
  67   hPutChar stdout '\n'
  68   exitWith ExitSuccess
  69
  70 addPackage :: [PackageConfig] -> FilePath -> IO ()
  71 addPackage details pkgconf = do
  72   checkConfigAccess pkgconf
  73   hPutStr stdout "Reading package info from stdin... "
  74   s <- getContents
  75   let new_pkg = read s :: PackageConfig
  76   eval_catch new_pkg (\_ -> die "parse error in package info")
  77   hPutStrLn stdout "done."
  78   if (name new_pkg `elem` map name details)
  79         then die ("package `" ++ name new_pkg ++ "' already installed")
  80         else do
  81   savePackageConfig pkgconf
  82   maybeRestoreOldConfig pkgconf $ do
  83   writeNewConfig pkgconf (details ++ [new_pkg])
  84   exitWith ExitSuccess
  85
  86 removePackage :: [PackageConfig] -> FilePath -> String -> IO ()
  87 removePackage details pkgconf pkg = do
  88   checkConfigAccess pkgconf
  89   if (pkg `notElem` map name details)
  90         then die ("package `" ++ pkg ++ "' not installed")
  91         else do
  92   savePackageConfig pkgconf
  93   maybeRestoreOldConfig pkgconf $ do
  94   writeNewConfig pkgconf (filter ((/= pkg) . name) details)
  95   exitWith ExitSuccess
  96
  97 checkConfigAccess :: FilePath -> IO ()
  98 checkConfigAccess pkgconf = do
  99   access <- getPermissions pkgconf
 100   when (not (writable access))
 101       (die "you don't have permission to modify the package configuration file")
 102
 103 maybeRestoreOldConfig :: String -> IO () -> IO ()
 104 maybeRestoreOldConfig conf_file io
 105   = my_catch io (\e -> do
 106         hPutStr stdout "\nWARNING: an error was encountered while the new \n\
 107                        \configuration was being written.  Attempting to \n\
 108                        \restore the old configuration... "
 109         renameFile (conf_file ++ ".old")  conf_file
 110         hPutStrLn stdout "done."
 111         my_throw e
 112     )
 113
 114 writeNewConfig :: String -> [PackageConfig] -> IO ()
 115 writeNewConfig conf_file details = do
 116   hPutStr stdout "Writing new package config file... "
 117   h <- openFile conf_file WriteMode
 118   hPutStr h (dumpPackages details )
 119   hClose h
 120   hPutStrLn stdout "done."
 121
 122 savePackageConfig :: String -> IO ()
 123 savePackageConfig conf_file = do
 124   hPutStr stdout "Saving old package config file... "
 125     -- mv rather than cp because we've already done an hGetContents
 126     -- on this file so we won't be able to open it for writing
 127     -- unless we move the old one out of the way...
 128   renameFile conf_file (conf_file ++ ".old")
 129   hPutStrLn stdout "done."
 130
 131 -----------------------------------------------------------------------------
 132
 133 die :: String -> IO a
 134 die s = do { hPutStrLn stderr s; exitWith (ExitFailure 1) }
 135
 136 -----------------------------------------------------------------------------
 137 -- Exceptions
 138
 139 #ifndef __GLASGOW_HASKELL__
 140
 141 eval_catch a h = a `seq` return ()
 142 my_catch = IO.catch
 143 my_throw = IO.fail
 144
 145 #else /* GHC */
 146
 147 my_throw = Exception.throw
 148 #if __GLASGOW_HASKELL__ > 408
 149 eval_catch = Exception.catch . Exception.evaluate
 150 my_catch = Exception.catch
 151 #else
 152 eval_catch = Exception.catchAll
 153 my_catch = Exception.catchAllIO
 154 #endif
 155
 156 #endif