ghc/utils/ghc-pkg/Main.hs

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