Main.hs 67 KB
Newer Older
1
{-# LANGUAGE PatternGuards, CPP, ForeignFunctionInterface #-}
2
-----------------------------------------------------------------------------
3
--
4
-- (c) The University of Glasgow 2004-2009.
5
--
6
-- Package management tool
7
--
8 9
-----------------------------------------------------------------------------

10 11
module Main (main) where

Ian Lynagh's avatar
Ian Lynagh committed
12
import Version ( version, targetOS, targetARCH )
13
import Distribution.InstalledPackageInfo.Binary()
14
import qualified Distribution.Simple.PackageIndex as PackageIndex
Simon Marlow's avatar
Simon Marlow committed
15
import Distribution.ModuleName hiding (main)
16
import Distribution.InstalledPackageInfo
17
import Distribution.Compat.ReadP
18
import Distribution.ParseUtils
19
import Distribution.Package hiding (depends)
20
import Distribution.Text
21
import Distribution.Version
22 23
import System.FilePath as FilePath
import qualified System.FilePath.Posix as FilePath.Posix
24
import System.Cmd       ( rawSystem )
25 26 27
import System.Directory ( getAppUserDataDirectory, createDirectoryIfMissing,
                          getModificationTime )
import Text.Printf
28

29
import Prelude
30

31 32
import System.Console.GetOpt
import qualified Control.Exception as Exception
33
import Data.Maybe
Ian Lynagh's avatar
Ian Lynagh committed
34

35
import Data.Char ( isSpace, toLower )
36
import Control.Monad
37
import System.Directory ( doesDirectoryExist, getDirectoryContents,
38 39
                          doesFileExist, renameFile, removeFile,
                          getCurrentDirectory )
40 41
import System.Exit ( exitWith, ExitCode(..) )
import System.Environment ( getArgs, getProgName, getEnv )
42
import System.IO
43
import System.IO.Error
44
import Data.List
45
import Control.Concurrent
46

47 48 49 50
import qualified Data.ByteString.Lazy as B
import qualified Data.Binary as Bin
import qualified Data.Binary.Get as Bin

51
#if defined(mingw32_HOST_OS)
Simon Marlow's avatar
Simon Marlow committed
52
-- mingw32 needs these for getExecDir, GHC <6.12 needs them for openNewFile
53
import Foreign
Simon Marlow's avatar
Simon Marlow committed
54
import Foreign.C
Simon Marlow's avatar
Simon Marlow committed
55 56
#endif

57
#ifdef mingw32_HOST_OS
58 59
import GHC.ConsoleHandler
#else
60
import System.Posix hiding (fdToHandle)
rrt's avatar
rrt committed
61 62
#endif

63 64 65 66 67
#if defined(GLOB)
import System.Process(runInteractiveCommand)
import qualified System.Info(os)
#endif

68
#if !defined(mingw32_HOST_OS) && !defined(BOOTSTRAPPING)
69 70 71
import System.Console.Terminfo as Terminfo
#endif

72 73 74
-- -----------------------------------------------------------------------------
-- Entry point

75
main :: IO ()
76 77 78
main = do
  args <- getArgs

79
  case getOpt Permute (flags ++ deprecFlags) args of
Ian Lynagh's avatar
Ian Lynagh committed
80 81 82 83 84 85
        (cli,_,[]) | FlagHelp `elem` cli -> do
           prog <- getProgramName
           bye (usageInfo (usageHeader prog) flags)
        (cli,_,[]) | FlagVersion `elem` cli ->
           bye ourCopyright
        (cli,nonopts,[]) ->
86 87 88
           case getVerbosity Normal cli of
           Right v -> runit v cli nonopts
           Left err -> die err
89
        (_,_,errors) -> do
Ian Lynagh's avatar
Ian Lynagh committed
90 91
           prog <- getProgramName
           die (concat errors ++ usageInfo (usageHeader prog) flags)
92

93 94
-- -----------------------------------------------------------------------------
-- Command-line syntax
95

96 97 98 99 100
data Flag
  = FlagUser
  | FlagGlobal
  | FlagHelp
  | FlagVersion
Ian Lynagh's avatar
Ian Lynagh committed
101
  | FlagConfig FilePath
102 103
  | FlagGlobalConfig FilePath
  | FlagForce
104
  | FlagForceFiles
105
  | FlagAutoGHCiLibs
106
  | FlagExpandEnvVars
107 108
  | FlagExpandPkgroot
  | FlagNoExpandPkgroot
109
  | FlagSimpleOutput
110
  | FlagNamesOnly
111
  | FlagIgnoreCase
Simon Marlow's avatar
Simon Marlow committed
112
  | FlagNoUserDb
113
  | FlagVerbosity (Maybe String)
114
  deriving Eq
115

116
flags :: [OptDescr Flag]
117
flags = [
118
  Option [] ["user"] (NoArg FlagUser)
Ian Lynagh's avatar
Ian Lynagh committed
119
        "use the current user's package database",
120
  Option [] ["global"] (NoArg FlagGlobal)
121
        "use the global package database",
122
  Option ['f'] ["package-conf"] (ReqArg FlagConfig "FILE")
123
        "use the specified package config file",
124
  Option [] ["global-conf"] (ReqArg FlagGlobalConfig "FILE")
Ian Lynagh's avatar
Ian Lynagh committed
125
        "location of the global package config",
Simon Marlow's avatar
Simon Marlow committed
126 127
  Option [] ["no-user-package-conf"] (NoArg FlagNoUserDb)
        "never read the user package database",
128
  Option [] ["force"] (NoArg FlagForce)
Ian Lynagh's avatar
Ian Lynagh committed
129
         "ignore missing dependencies, directories, and libraries",
130
  Option [] ["force-files"] (NoArg FlagForceFiles)
Ian Lynagh's avatar
Ian Lynagh committed
131
         "ignore missing directories and libraries only",
132
  Option ['g'] ["auto-ghci-libs"] (NoArg FlagAutoGHCiLibs)
Ian Lynagh's avatar
Ian Lynagh committed
133
        "automatically build libs for GHCi (with register)",
134 135
  Option [] ["expand-env-vars"] (NoArg FlagExpandEnvVars)
        "expand environment variables (${name}-style) in input package descriptions",
136 137 138 139
  Option [] ["expand-pkgroot"] (NoArg FlagExpandPkgroot)
        "expand ${pkgroot}-relative paths to absolute in output package descriptions",
  Option [] ["no-expand-pkgroot"] (NoArg FlagNoExpandPkgroot)
        "preserve ${pkgroot}-relative paths in output package descriptions",
140
  Option ['?'] ["help"] (NoArg FlagHelp)
Ian Lynagh's avatar
Ian Lynagh committed
141
        "display this help and exit",
142
  Option ['V'] ["version"] (NoArg FlagVersion)
Ian Lynagh's avatar
Ian Lynagh committed
143
        "output version information and exit",
144
  Option [] ["simple-output"] (NoArg FlagSimpleOutput)
145 146
        "print output in easy-to-parse format for some commands",
  Option [] ["names-only"] (NoArg FlagNamesOnly)
147 148
        "only print package names, not versions; can only be used with list --simple-output",
  Option [] ["ignore-case"] (NoArg FlagIgnoreCase)
149 150 151
        "ignore case for substring matching",
  Option ['v'] ["verbose"] (OptArg FlagVerbosity "Verbosity")
        "verbosity level (0-2, default 1)"
152
  ]
153

154 155 156 157 158 159 160 161 162 163 164 165
data Verbosity = Silent | Normal | Verbose
    deriving (Show, Eq, Ord)

getVerbosity :: Verbosity -> [Flag] -> Either String Verbosity
getVerbosity v [] = Right v
getVerbosity _ (FlagVerbosity Nothing    : fs) = getVerbosity Verbose fs
getVerbosity _ (FlagVerbosity (Just "0") : fs) = getVerbosity Silent  fs
getVerbosity _ (FlagVerbosity (Just "1") : fs) = getVerbosity Normal  fs
getVerbosity _ (FlagVerbosity (Just "2") : fs) = getVerbosity Verbose fs
getVerbosity _ (FlagVerbosity v : _) = Left ("Bad verbosity: " ++ show v)
getVerbosity v (_ : fs) = getVerbosity v fs

166 167
deprecFlags :: [OptDescr Flag]
deprecFlags = [
168
        -- put deprecated flags here
169
  ]
170 171

ourCopyright :: String
172
ourCopyright = "GHC package manager version " ++ Version.version ++ "\n"
173 174 175 176

usageHeader :: String -> String
usageHeader prog = substProg prog $
  "Usage:\n" ++
177 178 179 180 181 182
  "  $p init {path}\n" ++
  "    Create and initialise a package database at the location {path}.\n" ++
  "    Packages can be registered in the new database using the register\n" ++
  "    command with --package-conf={path}.  To use the new database with GHC,\n" ++
  "    use GHC's -package-conf flag.\n" ++
  "\n" ++
183
  "  $p register {filename | -}\n" ++
184 185
  "    Register the package using the specified installed package\n" ++
  "    description. The syntax for the latter is given in the $p\n" ++
186
  "    documentation.  The input file should be encoded in UTF-8.\n" ++
187
  "\n" ++
188 189
  "  $p update {filename | -}\n" ++
  "    Register the package, overwriting any other package with the\n" ++
190
  "    same name. The input file should be encoded in UTF-8.\n" ++
191
  "\n" ++
192 193 194 195 196 197 198 199 200
  "  $p unregister {pkg-id}\n" ++
  "    Unregister the specified package.\n" ++
  "\n" ++
  "  $p expose {pkg-id}\n" ++
  "    Expose the specified package.\n" ++
  "\n" ++
  "  $p hide {pkg-id}\n" ++
  "    Hide the specified package.\n" ++
  "\n" ++
201 202 203
  "  $p list [pkg]\n" ++
  "    List registered packages in the global database, and also the\n" ++
  "    user database if --user is given. If a package name is given\n" ++
Ian Lynagh's avatar
Ian Lynagh committed
204
  "    all the registered versions will be listed in ascending order.\n" ++
205 206
  "    Accepts the --simple-output flag.\n" ++
  "\n" ++
207 208 209 210 211
  "  $p dot\n" ++
  "    Generate a graph of the package dependencies in a form suitable\n" ++
  "    for input for the graphviz tools.  For example, to generate a PDF" ++
  "    of the dependency graph: ghc-pkg dot | tred | dot -Tpdf >pkgs.pdf" ++
  "\n" ++
212 213
  "  $p find-module {module}\n" ++
  "    List registered packages exposing module {module} in the global\n" ++
Ian Lynagh's avatar
Ian Lynagh committed
214
  "    database, and also the user database if --user is given.\n" ++
215
  "    All the registered versions will be listed in ascending order.\n" ++
216
  "    Accepts the --simple-output flag.\n" ++
217
  "\n" ++
218
  "  $p latest {pkg-id}\n" ++
219
  "    Prints the highest registered version of a package.\n" ++
220
  "\n" ++
221 222 223 224
  "  $p check\n" ++
  "    Check the consistency of package depenencies and list broken packages.\n" ++
  "    Accepts the --simple-output flag.\n" ++
  "\n" ++
225
  "  $p describe {pkg}\n" ++
226 227 228 229
  "    Give the registered description for the specified package. The\n" ++
  "    description is returned in precisely the syntax required by $p\n" ++
  "    register.\n" ++
  "\n" ++
230
  "  $p field {pkg} {field}\n" ++
231
  "    Extract the specified field of the package description for the\n" ++
232 233
  "    specified package. Accepts comma-separated multiple fields.\n" ++
  "\n" ++
234 235 236
  "  $p dump\n" ++
  "    Dump the registered description for every package.  This is like\n" ++
  "    \"ghc-pkg describe '*'\", except that it is intended to be used\n" ++
237 238
  "    by tools that parse the results, rather than humans.  The output is\n" ++
  "    always encoded in UTF-8, regardless of the current locale.\n" ++
239
  "\n" ++
240 241 242 243 244 245 246
  "  $p recache\n" ++
  "    Regenerate the package database cache.  This command should only be\n" ++
  "    necessary if you added a package to the database by dropping a file\n" ++
  "    into the database directory manually.  By default, the global DB\n" ++
  "    is recached; to recache a different DB use --user or --package-conf\n" ++
  "    as appropriate.\n" ++
  "\n" ++
247 248 249
  " Substring matching is supported for {module} in find-module and\n" ++
  " for {pkg} in list, describe, and field, where a '*' indicates\n" ++
  " open substring ends (prefix*, *suffix, *infix*).\n" ++
250
  "\n" ++
251 252 253 254 255 256 257
  "  When asked to modify a database (register, unregister, update,\n"++
  "  hide, expose, and also check), ghc-pkg modifies the global database by\n"++
  "  default.  Specifying --user causes it to act on the user database,\n"++
  "  or --package-conf can be used to act on another database\n"++
  "  entirely. When multiple of these options are given, the rightmost\n"++
  "  one is used as the database to act upon.\n"++
  "\n"++
258
  "  Commands that query the package database (list, tree, latest, describe,\n"++
259 260 261 262
  "  field) operate on the list of databases specified by the flags\n"++
  "  --user, --global, and --package-conf.  If none of these flags are\n"++
  "  given, the default is --global --user.\n"++
  "\n" ++
263
  " The following optional flags are also accepted:\n"
264 265 266 267 268 269 270 271 272

substProg :: String -> String -> String
substProg _ [] = []
substProg prog ('$':'p':xs) = prog ++ substProg prog xs
substProg prog (c:xs) = c : substProg prog xs

-- -----------------------------------------------------------------------------
-- Do the business

Simon Marlow's avatar
Simon Marlow committed
273 274
data Force = NoForce | ForceFiles | ForceAll | CannotForce
  deriving (Eq,Ord)
275

276 277
data PackageArg = Id PackageIdentifier | Substring String (String->Bool)

278 279
runit :: Verbosity -> [Flag] -> [String] -> IO ()
runit verbosity cli nonopts = do
280
  installSignalHandlers -- catch ^C and clean up
281 282
  prog <- getProgramName
  let
Ian Lynagh's avatar
Ian Lynagh committed
283 284
        force
          | FlagForce `elem` cli        = ForceAll
285 286
          | FlagForceFiles `elem` cli   = ForceFiles
          | otherwise                   = NoForce
Ian Lynagh's avatar
Ian Lynagh committed
287
        auto_ghci_libs = FlagAutoGHCiLibs `elem` cli
288
        expand_env_vars= FlagExpandEnvVars `elem` cli
289 290 291 292 293
        mexpand_pkgroot= foldl' accumExpandPkgroot Nothing cli
          where accumExpandPkgroot _ FlagExpandPkgroot   = Just True
                accumExpandPkgroot _ FlagNoExpandPkgroot = Just False
                accumExpandPkgroot x _                   = x
                
294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317
        splitFields fields = unfoldr splitComma (',':fields)
          where splitComma "" = Nothing
                splitComma fs = Just $ break (==',') (tail fs)

        substringCheck :: String -> Maybe (String -> Bool)
        substringCheck ""    = Nothing
        substringCheck "*"   = Just (const True)
        substringCheck [_]   = Nothing
        substringCheck (h:t) =
          case (h, init t, last t) of
            ('*',s,'*') -> Just (isInfixOf (f s) . f)
            ('*',_, _ ) -> Just (isSuffixOf (f t) . f)
            ( _ ,s,'*') -> Just (isPrefixOf (f (h:s)) . f)
            _           -> Nothing
          where f | FlagIgnoreCase `elem` cli = map toLower
                  | otherwise                 = id
#if defined(GLOB)
        glob x | System.Info.os=="mingw32" = do
          -- glob echoes its argument, after win32 filename globbing
          (_,o,_,_) <- runInteractiveCommand ("glob "++x)
          txt <- hGetContents o
          return (read txt)
        glob x | otherwise = return [x]
#endif
318 319 320
  --
  -- first, parse the command
  case nonopts of
321 322 323 324 325 326 327 328 329
#if defined(GLOB)
    -- dummy command to demonstrate usage and permit testing
    -- without messing things up; use glob to selectively enable
    -- windows filename globbing for file parameters
    -- register, update, FlagGlobalConfig, FlagConfig; others?
    ["glob", filename] -> do
        print filename
        glob filename >>= print
#endif
330 331
    ["init", filename] ->
        initPackageDB filename verbosity cli
Ian Lynagh's avatar
Ian Lynagh committed
332
    ["register", filename] ->
333 334
        registerPackage filename verbosity cli
                        auto_ghci_libs expand_env_vars False force
Ian Lynagh's avatar
Ian Lynagh committed
335
    ["update", filename] ->
336 337
        registerPackage filename verbosity cli
                        auto_ghci_libs expand_env_vars True force
338
    ["unregister", pkgid_str] -> do
Ian Lynagh's avatar
Ian Lynagh committed
339
        pkgid <- readGlobPkgId pkgid_str
340
        unregisterPackage pkgid verbosity cli force
341
    ["expose", pkgid_str] -> do
Ian Lynagh's avatar
Ian Lynagh committed
342
        pkgid <- readGlobPkgId pkgid_str
343
        exposePackage pkgid verbosity cli force
344
    ["hide",   pkgid_str] -> do
Ian Lynagh's avatar
Ian Lynagh committed
345
        pkgid <- readGlobPkgId pkgid_str
346
        hidePackage pkgid verbosity cli force
347
    ["list"] -> do
348
        listPackages verbosity cli Nothing Nothing
349 350 351
    ["list", pkgid_str] ->
        case substringCheck pkgid_str of
          Nothing -> do pkgid <- readGlobPkgId pkgid_str
352 353 354 355
                        listPackages verbosity cli (Just (Id pkgid)) Nothing
          Just m -> listPackages verbosity cli (Just (Substring pkgid_str m)) Nothing
    ["dot"] -> do
        showPackageDot verbosity cli
356
    ["find-module", moduleName] -> do
357
        let match = maybe (==moduleName) id (substringCheck moduleName)
358
        listPackages verbosity cli Nothing (Just match)
359
    ["latest", pkgid_str] -> do
Ian Lynagh's avatar
Ian Lynagh committed
360
        pkgid <- readGlobPkgId pkgid_str
361
        latestPackage verbosity cli pkgid
362 363 364 365 366 367 368 369 370 371 372 373 374
    ["describe", pkgid_str] -> do
        pkgarg <- case substringCheck pkgid_str of
          Nothing -> liftM Id (readGlobPkgId pkgid_str)
          Just m  -> return (Substring pkgid_str m)
        describePackage verbosity cli pkgarg (fromMaybe False mexpand_pkgroot)
        
    ["field", pkgid_str, fields] -> do
        pkgarg <- case substringCheck pkgid_str of
          Nothing -> liftM Id (readGlobPkgId pkgid_str)
          Just m  -> return (Substring pkgid_str m)
        describeField verbosity cli pkgarg
                      (splitFields fields) (fromMaybe True mexpand_pkgroot)

375
    ["check"] -> do
376
        checkConsistency verbosity cli
377 378

    ["dump"] -> do
379
        dumpPackages verbosity cli (fromMaybe False mexpand_pkgroot)
380 381 382

    ["recache"] -> do
        recache verbosity cli
383

384
    [] -> do
Ian Lynagh's avatar
Ian Lynagh committed
385 386
        die ("missing command\n" ++
                usageInfo (usageHeader prog) flags)
387
    (_cmd:_) -> do
Ian Lynagh's avatar
Ian Lynagh committed
388 389
        die ("command-line syntax error\n" ++
                usageInfo (usageHeader prog) flags)
390 391

parseCheck :: ReadP a a -> String -> String -> IO a
Ian Lynagh's avatar
Ian Lynagh committed
392
parseCheck parser str what =
393 394
  case [ x | (x,ys) <- readP_to_S parser str, all isSpace ys ] of
    [x] -> return x
395 396
    _ -> die ("cannot parse \'" ++ str ++ "\' as a " ++ what)

397 398 399 400
readGlobPkgId :: String -> IO PackageIdentifier
readGlobPkgId str = parseCheck parseGlobPackageId str "package identifier"

parseGlobPackageId :: ReadP r PackageIdentifier
Ian Lynagh's avatar
Ian Lynagh committed
401
parseGlobPackageId =
402
  parse
403
     +++
Ian Lynagh's avatar
Ian Lynagh committed
404
  (do n <- parse
405
      _ <- string "-*"
406 407 408
      return (PackageIdentifier{ pkgName = n, pkgVersion = globVersion }))

-- globVersion means "all versions"
409
globVersion :: Version
410 411
globVersion = Version{ versionBranch=[], versionTags=["*"] }

412 413 414 415
-- -----------------------------------------------------------------------------
-- Package databases

-- Some commands operate on a single database:
Ian Lynagh's avatar
Ian Lynagh committed
416
--      register, unregister, expose, hide
417 418 419 420 421
-- however these commands also check the union of the available databases
-- in order to check consistency.  For example, register will check that
-- dependencies exist before registering a package.
--
-- Some commands operate  on multiple databases, with overlapping semantics:
Ian Lynagh's avatar
Ian Lynagh committed
422
--      list, describe, field
423

424
data PackageDB 
425 426 427 428 429 430 431 432 433 434
  = PackageDB {
      location, locationAbsolute :: !FilePath,
      -- We need both possibly-relative and definately-absolute package
      -- db locations. This is because the relative location is used as
      -- an identifier for the db, so it is important we do not modify it.
      -- On the other hand we need the absolute path in a few places
      -- particularly in relation to the ${pkgroot} stuff.
      
      packages :: [InstalledPackageInfo]
    }
435

436
type PackageDBStack = [PackageDB]
Ian Lynagh's avatar
Ian Lynagh committed
437
        -- A stack of package databases.  Convention: head is the topmost
438
        -- in the stack.
439

440
allPackagesInStack :: PackageDBStack -> [InstalledPackageInfo]
441
allPackagesInStack = concatMap packages
442

443 444 445
getPkgDatabases :: Verbosity
                -> Bool    -- we are modifying, not reading
                -> Bool    -- read caches, if available
446
                -> Bool    -- expand vars, like ${pkgroot} and $topdir
447 448 449 450 451 452 453 454 455 456 457 458
                -> [Flag]
                -> IO (PackageDBStack, 
                          -- the real package DB stack: [global,user] ++ 
                          -- DBs specified on the command line with -f.
                       Maybe FilePath,
                          -- which one to modify, if any
                       PackageDBStack)
                          -- the package DBs specified on the command
                          -- line, or [global,user] otherwise.  This
                          -- is used as the list of package DBs for
                          -- commands that just read the DB, such as 'list'.

459
getPkgDatabases verbosity modify use_cache expand_vars my_flags = do
460 461 462 463 464
  -- first we determine the location of the global package config.  On Windows,
  -- this is found relative to the ghc-pkg.exe binary, whereas on Unix the
  -- location is passed to the binary using the --global-config flag by the
  -- wrapper script.
  let err_msg = "missing --global-conf option, location of global package.conf unknown\n"
Ian Lynagh's avatar
Ian Lynagh committed
465
  global_conf <-
466
     case [ f | FlagGlobalConfig f <- my_flags ] of
Ian Lynagh's avatar
Ian Lynagh committed
467
        [] -> do mb_dir <- getLibDir
Ian Lynagh's avatar
Ian Lynagh committed
468
                 case mb_dir of
469 470 471 472 473 474
                   Nothing  -> die err_msg
                   Just dir -> do
                     r <- lookForPackageDBIn dir
                     case r of
                       Nothing -> die ("Can't find package database in " ++ dir)
                       Just path -> return path
475 476
        fs -> return (last fs)

477 478 479 480 481 482
  -- The value of the $topdir variable used in some package descriptions
  -- Note that the way we calculate this is slightly different to how it
  -- is done in ghc itself. We rely on the convention that the global
  -- package db lives in ghc's libdir.
  top_dir <- absolutePath (takeDirectory global_conf)

Simon Marlow's avatar
Simon Marlow committed
483 484
  let no_user_db = FlagNoUserDb `elem` my_flags

485
  -- get the location of the user package database, and create it if necessary
486
  -- getAppUserDataDirectory can fail (e.g. if $HOME isn't set)
487
  e_appdir <- tryIO $ getAppUserDataDirectory "ghc"
488 489

  mb_user_conf <-
Simon Marlow's avatar
Simon Marlow committed
490
     if no_user_db then return Nothing else
491 492 493 494 495 496 497 498 499
     case e_appdir of
       Left _    -> return Nothing
       Right appdir -> do
         let subdir = targetARCH ++ '-':targetOS ++ '-':Version.version
             dir = appdir </> subdir
         r <- lookForPackageDBIn dir
         case r of
           Nothing -> return (Just (dir </> "package.conf.d", False))
           Just f  -> return (Just (f, True))
500

501 502 503
  -- If the user database doesn't exist, and this command isn't a
  -- "modify" command, then we won't attempt to create or use it.
  let sys_databases
504
        | Just (user_conf,user_exists) <- mb_user_conf,
505 506
          modify || user_exists = [user_conf, global_conf]
        | otherwise             = [global_conf]
507

508
  e_pkg_path <- tryIO (System.Environment.getEnv "GHC_PACKAGE_PATH")
509
  let env_stack =
Ian Lynagh's avatar
Ian Lynagh committed
510 511 512 513 514
        case e_pkg_path of
                Left  _ -> sys_databases
                Right path
                  | last cs == ""  -> init cs ++ sys_databases
                  | otherwise      -> cs
515
                  where cs = parseSearchPath path
Ian Lynagh's avatar
Ian Lynagh committed
516 517 518

        -- The "global" database is always the one at the bottom of the stack.
        -- This is the database we modify by default.
519 520
      virt_global_conf = last env_stack

521
  let db_flags = [ f | Just f <- map is_db_flag my_flags ]
522
         where is_db_flag FlagUser
Ian Lynagh's avatar
Ian Lynagh committed
523
                      | Just (user_conf, _user_exists) <- mb_user_conf 
524
                      = Just user_conf
525 526 527
               is_db_flag FlagGlobal     = Just virt_global_conf
               is_db_flag (FlagConfig f) = Just f
               is_db_flag _              = Nothing
528

529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550
  let flag_db_names | null db_flags = env_stack
                    | otherwise     = reverse (nub db_flags)

  -- For a "modify" command, treat all the databases as
  -- a stack, where we are modifying the top one, but it
  -- can refer to packages in databases further down the
  -- stack.

  -- -f flags on the command line add to the database
  -- stack, unless any of them are present in the stack
  -- already.
  let final_stack = filter (`notElem` env_stack)
                     [ f | FlagConfig f <- reverse my_flags ]
                     ++ env_stack

  -- the database we actually modify is the one mentioned
  -- rightmost on the command-line.
  let to_modify
        | not modify    = Nothing
        | null db_flags = Just virt_global_conf
        | otherwise     = Just (last db_flags)

551 552
  db_stack  <- sequence
    [ do db <- readParseDatabase verbosity mb_user_conf use_cache db_path
553 554
         if expand_vars then return (mungePackageDBPaths top_dir db)
                        else return db
555
    | db_path <- final_stack ]
556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578

  let flag_db_stack = [ db | db_name <- flag_db_names,
                        db <- db_stack, location db == db_name ]

  return (db_stack, to_modify, flag_db_stack)


lookForPackageDBIn :: FilePath -> IO (Maybe FilePath)
lookForPackageDBIn dir = do
  let path_dir = dir </> "package.conf.d"
  exists_dir <- doesDirectoryExist path_dir
  if exists_dir then return (Just path_dir) else do
  let path_file = dir </> "package.conf"
  exists_file <- doesFileExist path_file
  if exists_file then return (Just path_file) else return Nothing

readParseDatabase :: Verbosity
                  -> Maybe (FilePath,Bool)
                  -> Bool -- use cache
                  -> FilePath
                  -> IO PackageDB

readParseDatabase verbosity mb_user_conf use_cache path
579
  -- the user database (only) is allowed to be non-existent
580
  | Just (user_conf,False) <- mb_user_conf, path == user_conf
581
  = mkPackageDB []
582
  | otherwise
583
  = do e <- tryIO $ getDirectoryContents path
584 585 586
       case e of
         Left _   -> do
              pkgs <- parseMultiPackageConf verbosity path
587
              mkPackageDB pkgs
588 589 590 591 592
         Right fs
           | not use_cache -> ignore_cache
           | otherwise -> do
              let cache = path </> cachefilename
              tdir     <- getModificationTime path
593
              e_tcache <- tryIO $ getModificationTime cache
594 595 596
              case e_tcache of
                Left ex -> do
                     when (verbosity > Normal) $
597
                        warn ("warning: cannot read cache file " ++ cache ++ ": " ++ show ex)
598 599 600 601 602
                     ignore_cache
                Right tcache
                  | tcache >= tdir -> do
                     when (verbosity > Normal) $
                        putStrLn ("using cache: " ++ cache)
603
                     pkgs <- myReadBinPackageDB cache
604
                     let pkgs' = map convertPackageInfoIn pkgs
605
                     mkPackageDB pkgs'
606 607
                  | otherwise -> do
                     when (verbosity >= Normal) $ do
608 609
                        warn ("WARNING: cache is out of date: " ++ cache)
                        warn "  use 'ghc-pkg recache' to fix."
610 611 612 613 614 615
                     ignore_cache
            where
                 ignore_cache = do
                     let confs = filter (".conf" `isSuffixOf`) fs
                     pkgs <- mapM (parseSingletonPackageConf verbosity) $
                                   map (path </>) confs
616 617 618 619 620 621 622 623 624
                     mkPackageDB pkgs
  where
    mkPackageDB pkgs = do
      path_abs <- absolutePath path
      return PackageDB {
        location = path,
        locationAbsolute = path_abs,
        packages = pkgs
      }
625

626 627 628 629 630 631 632 633 634 635 636
-- read the package.cache file strictly, to work around a problem with
-- bytestring 0.9.0.x (fixed in 0.9.1.x) where the file wasn't closed
-- after it has been completely read, leading to a sharing violation
-- later.
myReadBinPackageDB :: FilePath -> IO [InstalledPackageInfoString]
myReadBinPackageDB filepath = do
  h <- openBinaryFile filepath ReadMode
  sz <- hFileSize h
  b <- B.hGet h (fromIntegral sz)
  hClose h
  return $ Bin.runGet Bin.get b
637 638 639 640

parseMultiPackageConf :: Verbosity -> FilePath -> IO [InstalledPackageInfo]
parseMultiPackageConf verbosity file = do
  when (verbosity > Normal) $ putStrLn ("reading package database: " ++ file)
641
  str <- readUTF8File file
642 643 644 645 646 647 648 649
  let pkgs = map convertPackageInfoIn $ read str
  Exception.evaluate pkgs
    `catchError` \e->
       die ("error while parsing " ++ file ++ ": " ++ show e)
  
parseSingletonPackageConf :: Verbosity -> FilePath -> IO InstalledPackageInfo
parseSingletonPackageConf verbosity file = do
  when (verbosity > Normal) $ putStrLn ("reading package config: " ++ file)
650
  readUTF8File file >>= fmap fst . parsePackageInfo
651 652 653

cachefilename :: FilePath
cachefilename = "package.cache"
654

655 656 657 658 659
mungePackageDBPaths :: FilePath -> PackageDB -> PackageDB
mungePackageDBPaths top_dir db@PackageDB { packages = pkgs } =
    db { packages = map (mungePackagePaths top_dir pkgroot) pkgs }
  where
    pkgroot = takeDirectory (locationAbsolute db)    
660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712
    -- It so happens that for both styles of package db ("package.conf"
    -- files and "package.conf.d" dirs) the pkgroot is the parent directory
    -- ${pkgroot}/package.conf  or  ${pkgroot}/package.conf.d/

mungePackagePaths :: FilePath -> FilePath
                  -> InstalledPackageInfo -> InstalledPackageInfo
-- Perform path/URL variable substitution as per the Cabal ${pkgroot} spec
-- (http://www.haskell.org/pipermail/libraries/2009-May/011772.html)
-- Paths/URLs can be relative to ${pkgroot} or ${pkgrooturl}.
-- The "pkgroot" is the directory containing the package database.
--
-- Also perform a similar substitution for the older GHC-specific
-- "$topdir" variable. The "topdir" is the location of the ghc
-- installation (obtained from the -B option).
mungePackagePaths top_dir pkgroot pkg =
    pkg {
      importDirs  = munge_paths (importDirs pkg),
      includeDirs = munge_paths (includeDirs pkg),
      libraryDirs = munge_paths (libraryDirs pkg),
      frameworkDirs = munge_paths (frameworkDirs pkg),
      haddockInterfaces = munge_paths (haddockInterfaces pkg),
      haddockHTMLs = munge_urls (haddockHTMLs pkg)
    }
  where
    munge_paths = map munge_path
    munge_urls  = map munge_url

    munge_path p
      | Just p' <- stripVarPrefix "${pkgroot}" sp = pkgroot </> p'
      | Just p' <- stripVarPrefix "$topdir"    sp = top_dir </> p'
      | otherwise                                 = p
      where
        sp = splitPath p

    munge_url p
      | Just p' <- stripVarPrefix "${pkgrooturl}" sp = toUrlPath pkgroot p'
      | Just p' <- stripVarPrefix "$httptopdir"   sp = toUrlPath top_dir p'
      | otherwise                                    = p
      where
        sp = splitPath p

    toUrlPath r p = "file:///"
                 -- URLs always use posix style '/' separators:
                 ++ FilePath.Posix.joinPath (r : FilePath.splitDirectories p)

    stripVarPrefix var (root:path')
      | Just [sep] <- stripPrefix var root
      , isPathSeparator sep
      = Just (joinPath path')

    stripVarPrefix _ _ = Nothing


713 714 715 716 717 718 719 720 721 722
-- -----------------------------------------------------------------------------
-- Creating a new package DB

initPackageDB :: FilePath -> Verbosity -> [Flag] -> IO ()
initPackageDB filename verbosity _flags = do
  let eexist = die ("cannot create: " ++ filename ++ " already exists")
  b1 <- doesFileExist filename
  when b1 eexist
  b2 <- doesDirectoryExist filename
  when b2 eexist
723 724 725 726 727
  filename_abs <- absolutePath filename
  changeDB verbosity [] PackageDB {
                          location = filename, locationAbsolute = filename_abs,
                          packages = []
                        }
728

729 730 731 732
-- -----------------------------------------------------------------------------
-- Registering

registerPackage :: FilePath
733
                -> Verbosity
Ian Lynagh's avatar
Ian Lynagh committed
734 735
                -> [Flag]
                -> Bool              -- auto_ghci_libs
736
                -> Bool              -- expand_env_vars
Ian Lynagh's avatar
Ian Lynagh committed
737 738 739
                -> Bool              -- update
                -> Force
                -> IO ()
740
registerPackage input verbosity my_flags auto_ghci_libs expand_env_vars update force = do
741
  (db_stack, Just to_modify, _flag_dbs) <- 
742
      getPkgDatabases verbosity True True False{-expand vars-} my_flags
743

744
  let
745
        db_to_operate_on = my_head "register" $
746
                           filter ((== to_modify).location) db_stack
747
  --
748 749 750
  when (auto_ghci_libs && verbosity >= Silent) $
    warn "Warning: --auto-ghci-libs is deprecated and will be removed in GHC 7.4"
  --
sof's avatar
sof committed
751
  s <-
752
    case input of
sof's avatar
sof committed
753
      "-" -> do
754 755
        when (verbosity >= Normal) $
            putStr "Reading package info from stdin ... "
756 757
        -- fix the encoding to UTF-8, since this is an interchange format
        hSetEncoding stdin utf8
sof's avatar
sof committed
758 759
        getContents
      f   -> do
760 761
        when (verbosity >= Normal) $
            putStr ("Reading package info from " ++ show f ++ " ... ")
762
        readUTF8File f
763

764 765
  expanded <- if expand_env_vars then expandEnvVars s force
                                 else return s
766

767
  (pkg, ws) <- parsePackageInfo expanded
768 769
  when (verbosity >= Normal) $
      putStrLn "done."
770

771 772 773 774
  -- report any warnings from the parse phase
  _ <- reportValidateErrors [] ws
         (display (sourcePackageId pkg) ++ ": Warning: ") Nothing

775 776 777 778 779
  -- validate the expanded pkg, but register the unexpanded
  pkgroot <- absolutePath (takeDirectory to_modify)
  let top_dir = takeDirectory (location (last db_stack))
      pkg_expanded = mungePackagePaths top_dir pkgroot pkg

780
  let truncated_stack = dropWhile ((/= to_modify).location) db_stack
781 782
  -- truncate the stack for validation, because we don't allow
  -- packages lower in the stack to refer to those higher up.
783
  validatePackageConfig pkg_expanded truncated_stack auto_ghci_libs update force
784 785 786 787 788 789
  let 
     removes = [ RemovePackage p
               | p <- packages db_to_operate_on,
                 sourcePackageId p == sourcePackageId pkg ]
  --
  changeDB verbosity (removes ++ [AddPackage pkg]) db_to_operate_on
790 791

parsePackageInfo
Ian Lynagh's avatar
Ian Lynagh committed
792
        :: String
793
        -> IO (InstalledPackageInfo, [ValidateWarning])
794
parsePackageInfo str =
795
  case parseInstalledPackageInfo str of
796 797 798 799
    ParseOk warnings ok -> return (ok, ws)
      where
        ws = [ msg | PWarning msg <- warnings
                   , not ("Unrecognized field pkgroot" `isPrefixOf` msg) ]
800 801 802
    ParseFailed err -> case locatedErrorMsg err of
                           (Nothing, s) -> die s
                           (Just l, s) -> die (show l ++ ": " ++ s)
803

804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838
-- -----------------------------------------------------------------------------
-- Making changes to a package database

data DBOp = RemovePackage InstalledPackageInfo
          | AddPackage    InstalledPackageInfo
          | ModifyPackage InstalledPackageInfo

changeDB :: Verbosity -> [DBOp] -> PackageDB -> IO ()
changeDB verbosity cmds db = do
  let db' = updateInternalDB db cmds
  isfile <- doesFileExist (location db)
  if isfile
     then writeNewConfig verbosity (location db') (packages db')
     else do
       createDirectoryIfMissing True (location db)
       changeDBDir verbosity cmds db'

updateInternalDB :: PackageDB -> [DBOp] -> PackageDB
updateInternalDB db cmds = db{ packages = foldl do_cmd (packages db) cmds }
 where
  do_cmd pkgs (RemovePackage p) = 
    filter ((/= installedPackageId p) . installedPackageId) pkgs
  do_cmd pkgs (AddPackage p) = p : pkgs
  do_cmd pkgs (ModifyPackage p) = 
    do_cmd (do_cmd pkgs (RemovePackage p)) (AddPackage p)
    

changeDBDir :: Verbosity -> [DBOp] -> PackageDB -> IO ()
changeDBDir verbosity cmds db = do
  mapM_ do_cmd cmds
  updateDBCache verbosity db
 where
  do_cmd (RemovePackage p) = do
    let file = location db </> display (installedPackageId p) <.> "conf"
    when (verbosity > Normal) $ putStrLn ("removing " ++ file)
839
    removeFileSafe file
840 841 842
  do_cmd (AddPackage p) = do
    let file = location db </> display (installedPackageId p) <.> "conf"
    when (verbosity > Normal) $ putStrLn ("writing " ++ file)
Ian Lynagh's avatar
Ian Lynagh committed
843
    writeFileUtf8Atomic file (showInstalledPackageInfo p)
844 845 846 847 848 849 850 851
  do_cmd (ModifyPackage p) = 
    do_cmd (AddPackage p)

updateDBCache :: Verbosity -> PackageDB -> IO ()
updateDBCache verbosity db = do
  let filename = location db </> cachefilename
  when (verbosity > Normal) $
      putStrLn ("writing cache " ++ filename)
852
  writeBinaryFileAtomic filename (map convertPackageInfoOut (packages db))
853
    `catchIO` \e ->
854 855 856 857
      if isPermissionError e
      then die (filename ++ ": you don't have permission to modify this file")
      else ioError e

858
-- -----------------------------------------------------------------------------
859
-- Exposing, Hiding, Unregistering are all similar
860

861
exposePackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO ()
862
exposePackage = modifyPackage (\p -> ModifyPackage p{exposed=True})
863

864
hidePackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO ()
865
hidePackage = modifyPackage (\p -> ModifyPackage p{exposed=False})
866

867
unregisterPackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO ()
868
unregisterPackage = modifyPackage RemovePackage
869 870

modifyPackage
871
  :: (InstalledPackageInfo -> DBOp)
872
  -> PackageIdentifier
873
  -> Verbosity
874
  -> [Flag]
875
  -> Force
876
  -> IO ()
877
modifyPackage fn pkgid verbosity my_flags force = do
878
  (db_stack, Just _to_modify, _flag_dbs) <- 
879
      getPkgDatabases verbosity True{-modify-} True{-use cache-} False{-expand vars-} my_flags
880 881

  (db, ps) <- fmap head $ findPackagesByDB db_stack (Id pkgid)
882
  let 
883 884 885
      db_name = location db
      pkgs    = packages db

886
      pids = map sourcePackageId ps
887