ghc/utils/ghc-pkg/Main.hs

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