ghc/utils/ghc-pkg/Main.hs

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