ghc/utils/ghc-pkg/Main.hs

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