ghc/utils/ghc-pkg/Main.hs

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