Main.hs 68.6 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-db"] (ReqArg FlagConfig "FILE")
123
        "use the specified package config file",
124
  Option [] ["global-package-db"] (ReqArg FlagGlobalConfig "FILE")
Ian Lynagh's avatar
Ian Lynagh committed
125
        "location of the global package config",
126
  Option [] ["no-user-package-db"] (NoArg FlagNoUserDb)
Simon Marlow's avatar
Simon Marlow committed
127
        "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
  "  $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" ++
180 181
  "    command with --package-db={path}.  To use the new database with GHC,\n" ++
  "    use GHC's -package-db flag.\n" ++
182
  "\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 204 205 206
  "  $p trust {pkg-id}\n" ++
  "    Trust the specified package.\n" ++
  "\n" ++
  "  $p distrust {pkg-id}\n" ++
  "    Distrust the specified package.\n" ++
  "\n" ++
207 208 209
  "  $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
210
  "    all the registered versions will be listed in ascending order.\n" ++
211 212
  "    Accepts the --simple-output flag.\n" ++
  "\n" ++
213 214 215 216 217
  "  $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" ++
218 219
  "  $p find-module {module}\n" ++
  "    List registered packages exposing module {module} in the global\n" ++
Ian Lynagh's avatar
Ian Lynagh committed
220
  "    database, and also the user database if --user is given.\n" ++
221
  "    All the registered versions will be listed in ascending order.\n" ++
222
  "    Accepts the --simple-output flag.\n" ++
223
  "\n" ++
224
  "  $p latest {pkg-id}\n" ++
225
  "    Prints the highest registered version of a package.\n" ++
226
  "\n" ++
227 228 229 230
  "  $p check\n" ++
  "    Check the consistency of package depenencies and list broken packages.\n" ++
  "    Accepts the --simple-output flag.\n" ++
  "\n" ++
231
  "  $p describe {pkg}\n" ++
232 233 234 235
  "    Give the registered description for the specified package. The\n" ++
  "    description is returned in precisely the syntax required by $p\n" ++
  "    register.\n" ++
  "\n" ++
236
  "  $p field {pkg} {field}\n" ++
237
  "    Extract the specified field of the package description for the\n" ++
238 239
  "    specified package. Accepts comma-separated multiple fields.\n" ++
  "\n" ++
240 241 242
  "  $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" ++
243 244
  "    by tools that parse the results, rather than humans.  The output is\n" ++
  "    always encoded in UTF-8, regardless of the current locale.\n" ++
245
  "\n" ++
246 247 248 249
  "  $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" ++
250
  "    is recached; to recache a different DB use --user or --package-db\n" ++
251 252
  "    as appropriate.\n" ++
  "\n" ++
253 254 255
  " 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" ++
256
  "\n" ++
257 258 259
  "  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"++
260
  "  or --package-db can be used to act on another database\n"++
261 262 263
  "  entirely. When multiple of these options are given, the rightmost\n"++
  "  one is used as the database to act upon.\n"++
  "\n"++
264
  "  Commands that query the package database (list, tree, latest, describe,\n"++
265
  "  field) operate on the list of databases specified by the flags\n"++
266
  "  --user, --global, and --package-db.  If none of these flags are\n"++
267 268
  "  given, the default is --global --user.\n"++
  "\n" ++
269
  " The following optional flags are also accepted:\n"
270 271 272 273 274 275 276 277 278

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
279 280
data Force = NoForce | ForceFiles | ForceAll | CannotForce
  deriving (Eq,Ord)
281

282 283
data PackageArg = Id PackageIdentifier | Substring String (String->Bool)

284 285
runit :: Verbosity -> [Flag] -> [String] -> IO ()
runit verbosity cli nonopts = do
286
  installSignalHandlers -- catch ^C and clean up
287 288
  prog <- getProgramName
  let
Ian Lynagh's avatar
Ian Lynagh committed
289 290
        force
          | FlagForce `elem` cli        = ForceAll
291 292
          | FlagForceFiles `elem` cli   = ForceFiles
          | otherwise                   = NoForce
Ian Lynagh's avatar
Ian Lynagh committed
293
        auto_ghci_libs = FlagAutoGHCiLibs `elem` cli
294
        expand_env_vars= FlagExpandEnvVars `elem` cli
295 296 297 298 299
        mexpand_pkgroot= foldl' accumExpandPkgroot Nothing cli
          where accumExpandPkgroot _ FlagExpandPkgroot   = Just True
                accumExpandPkgroot _ FlagNoExpandPkgroot = Just False
                accumExpandPkgroot x _                   = x
                
300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323
        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
324 325 326
  --
  -- first, parse the command
  case nonopts of
327 328 329 330 331 332 333 334 335
#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
336 337
    ["init", filename] ->
        initPackageDB filename verbosity cli
Ian Lynagh's avatar
Ian Lynagh committed
338
    ["register", filename] ->
339 340
        registerPackage filename verbosity cli
                        auto_ghci_libs expand_env_vars False force
Ian Lynagh's avatar
Ian Lynagh committed
341
    ["update", filename] ->
342 343
        registerPackage filename verbosity cli
                        auto_ghci_libs expand_env_vars True force
344
    ["unregister", pkgid_str] -> do
Ian Lynagh's avatar
Ian Lynagh committed
345
        pkgid <- readGlobPkgId pkgid_str
346
        unregisterPackage pkgid verbosity cli force
347
    ["expose", pkgid_str] -> do
Ian Lynagh's avatar
Ian Lynagh committed
348
        pkgid <- readGlobPkgId pkgid_str
349
        exposePackage pkgid verbosity cli force
350
    ["hide",   pkgid_str] -> do
Ian Lynagh's avatar
Ian Lynagh committed
351
        pkgid <- readGlobPkgId pkgid_str
352
        hidePackage pkgid verbosity cli force
353 354 355 356 357 358
    ["trust",    pkgid_str] -> do
        pkgid <- readGlobPkgId pkgid_str
        trustPackage pkgid verbosity cli force
    ["distrust", pkgid_str] -> do
        pkgid <- readGlobPkgId pkgid_str
        distrustPackage pkgid verbosity cli force
359
    ["list"] -> do
360
        listPackages verbosity cli Nothing Nothing
361 362 363
    ["list", pkgid_str] ->
        case substringCheck pkgid_str of
          Nothing -> do pkgid <- readGlobPkgId pkgid_str
364 365 366 367
                        listPackages verbosity cli (Just (Id pkgid)) Nothing
          Just m -> listPackages verbosity cli (Just (Substring pkgid_str m)) Nothing
    ["dot"] -> do
        showPackageDot verbosity cli
368
    ["find-module", moduleName] -> do
369
        let match = maybe (==moduleName) id (substringCheck moduleName)
370
        listPackages verbosity cli Nothing (Just match)
371
    ["latest", pkgid_str] -> do
Ian Lynagh's avatar
Ian Lynagh committed
372
        pkgid <- readGlobPkgId pkgid_str
373
        latestPackage verbosity cli pkgid
374 375 376 377 378 379 380 381 382 383 384 385 386
    ["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)

387
    ["check"] -> do
388
        checkConsistency verbosity cli
389 390

    ["dump"] -> do
391
        dumpPackages verbosity cli (fromMaybe False mexpand_pkgroot)
392 393 394

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

396
    [] -> do
Ian Lynagh's avatar
Ian Lynagh committed
397 398
        die ("missing command\n" ++
                usageInfo (usageHeader prog) flags)
399
    (_cmd:_) -> do
Ian Lynagh's avatar
Ian Lynagh committed
400 401
        die ("command-line syntax error\n" ++
                usageInfo (usageHeader prog) flags)
402 403

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

409 410 411 412
readGlobPkgId :: String -> IO PackageIdentifier
readGlobPkgId str = parseCheck parseGlobPackageId str "package identifier"

parseGlobPackageId :: ReadP r PackageIdentifier
Ian Lynagh's avatar
Ian Lynagh committed
413
parseGlobPackageId =
414
  parse
415
     +++
Ian Lynagh's avatar
Ian Lynagh committed
416
  (do n <- parse
417
      _ <- string "-*"
418 419 420
      return (PackageIdentifier{ pkgName = n, pkgVersion = globVersion }))

-- globVersion means "all versions"
421
globVersion :: Version
422 423
globVersion = Version{ versionBranch=[], versionTags=["*"] }

424 425 426 427
-- -----------------------------------------------------------------------------
-- Package databases

-- Some commands operate on a single database:
428
--      register, unregister, expose, hide, trust, distrust
429 430 431 432 433
-- 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
434
--      list, describe, field
435

436
data PackageDB 
437 438 439 440 441 442 443 444 445 446
  = 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]
    }
447

448
type PackageDBStack = [PackageDB]
Ian Lynagh's avatar
Ian Lynagh committed
449
        -- A stack of package databases.  Convention: head is the topmost
450
        -- in the stack.
451

452
allPackagesInStack :: PackageDBStack -> [InstalledPackageInfo]
453
allPackagesInStack = concatMap packages
454

455 456 457
getPkgDatabases :: Verbosity
                -> Bool    -- we are modifying, not reading
                -> Bool    -- read caches, if available
458
                -> Bool    -- expand vars, like ${pkgroot} and $topdir
459 460 461 462 463 464 465 466 467 468 469 470
                -> [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'.

471
getPkgDatabases verbosity modify use_cache expand_vars my_flags = do
472 473
  -- 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
474
  -- location is passed to the binary using the --global-package-db flag by the
475
  -- wrapper script.
476
  let err_msg = "missing --global-package-db option, location of global package database unknown\n"
Ian Lynagh's avatar
Ian Lynagh committed
477
  global_conf <-
478
     case [ f | FlagGlobalConfig f <- my_flags ] of
Ian Lynagh's avatar
Ian Lynagh committed
479
        [] -> do mb_dir <- getLibDir
Ian Lynagh's avatar
Ian Lynagh committed
480
                 case mb_dir of
481 482 483 484 485 486
                   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
487 488
        fs -> return (last fs)

489 490 491 492 493 494
  -- 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
495 496
  let no_user_db = FlagNoUserDb `elem` my_flags

497
  -- get the location of the user package database, and create it if necessary
498
  -- getAppUserDataDirectory can fail (e.g. if $HOME isn't set)
499
  e_appdir <- tryIO $ getAppUserDataDirectory "ghc"
500 501

  mb_user_conf <-
Simon Marlow's avatar
Simon Marlow committed
502
     if no_user_db then return Nothing else
503 504 505 506 507 508 509 510 511
     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))
512

513 514 515
  -- 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
516
        | Just (user_conf,user_exists) <- mb_user_conf,
517 518
          modify || user_exists = [user_conf, global_conf]
        | otherwise             = [global_conf]
519

520
  e_pkg_path <- tryIO (System.Environment.getEnv "GHC_PACKAGE_PATH")
521
  let env_stack =
Ian Lynagh's avatar
Ian Lynagh committed
522 523 524 525 526
        case e_pkg_path of
                Left  _ -> sys_databases
                Right path
                  | last cs == ""  -> init cs ++ sys_databases
                  | otherwise      -> cs
527
                  where cs = parseSearchPath path
Ian Lynagh's avatar
Ian Lynagh committed
528 529 530

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

533
  let db_flags = [ f | Just f <- map is_db_flag my_flags ]
534
         where is_db_flag FlagUser
Ian Lynagh's avatar
Ian Lynagh committed
535
                      | Just (user_conf, _user_exists) <- mb_user_conf 
536
                      = Just user_conf
537 538 539
               is_db_flag FlagGlobal     = Just virt_global_conf
               is_db_flag (FlagConfig f) = Just f
               is_db_flag _              = Nothing
540

541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562
  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)

563 564
  db_stack  <- sequence
    [ do db <- readParseDatabase verbosity mb_user_conf use_cache db_path
565 566
         if expand_vars then return (mungePackageDBPaths top_dir db)
                        else return db
567
    | db_path <- final_stack ]
568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590

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

638 639 640 641 642 643 644 645 646 647 648
-- 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
649 650 651

parseMultiPackageConf :: Verbosity -> FilePath -> IO [InstalledPackageInfo]
parseMultiPackageConf verbosity file = do
652
  when (verbosity > Normal) $ infoLn ("reading package database: " ++ file)
653
  str <- readUTF8File file
654 655 656 657 658 659 660
  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
661
  when (verbosity > Normal) $ infoLn ("reading package config: " ++ file)
662
  readUTF8File file >>= fmap fst . parsePackageInfo
663 664 665

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

667 668 669 670 671
mungePackageDBPaths :: FilePath -> PackageDB -> PackageDB
mungePackageDBPaths top_dir db@PackageDB { packages = pkgs } =
    db { packages = map (mungePackagePaths top_dir pkgroot) pkgs }
  where
    pkgroot = takeDirectory (locationAbsolute db)    
672 673 674 675
    -- 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/

676
-- TODO: This code is duplicated in compiler/main/Packages.lhs
677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693
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),
694
                     -- haddock-html is allowed to be either a URL or a file
Ian Lynagh's avatar
Ian Lynagh committed
695
      haddockHTMLs = munge_paths (munge_urls (haddockHTMLs pkg))
696 697 698 699 700 701
    }
  where
    munge_paths = map munge_path
    munge_urls  = map munge_url

    munge_path p
702 703 704
      | Just p' <- stripVarPrefix "${pkgroot}" p = pkgroot ++ p'
      | Just p' <- stripVarPrefix "$topdir"    p = top_dir ++ p'
      | otherwise                                = p
705 706

    munge_url p
707 708 709
      | Just p' <- stripVarPrefix "${pkgrooturl}" p = toUrlPath pkgroot p'
      | Just p' <- stripVarPrefix "$httptopdir"   p = toUrlPath top_dir p'
      | otherwise                                   = p
710 711 712

    toUrlPath r p = "file:///"
                 -- URLs always use posix style '/' separators:
713 714 715 716 717 718 719 720 721 722 723 724 725
                 ++ FilePath.Posix.joinPath
                        (r : -- We need to drop a leading "/" or "\\"
                             -- if there is one:
                             dropWhile (all isPathSeparator)
                                       (FilePath.splitDirectories p))

    -- We could drop the separator here, and then use </> above. However,
    -- by leaving it in and using ++ we keep the same path separator
    -- rather than letting FilePath change it to use \ as the separator
    stripVarPrefix var path = case stripPrefix var path of
                              Just [] -> Just []
                              Just cs@(c : _) | isPathSeparator c -> Just cs
                              _ -> Nothing
726 727


728 729 730 731 732 733 734 735 736 737
-- -----------------------------------------------------------------------------
-- 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
738 739 740 741 742
  filename_abs <- absolutePath filename
  changeDB verbosity [] PackageDB {
                          location = filename, locationAbsolute = filename_abs,
                          packages = []
                        }
743

744 745 746 747
-- -----------------------------------------------------------------------------
-- Registering

registerPackage :: FilePath
748
                -> Verbosity
Ian Lynagh's avatar
Ian Lynagh committed
749 750
                -> [Flag]
                -> Bool              -- auto_ghci_libs
751
                -> Bool              -- expand_env_vars
Ian Lynagh's avatar
Ian Lynagh committed
752 753 754
                -> Bool              -- update
                -> Force
                -> IO ()
755
registerPackage input verbosity my_flags auto_ghci_libs expand_env_vars update force = do
756
  (db_stack, Just to_modify, _flag_dbs) <- 
757
      getPkgDatabases verbosity True True False{-expand vars-} my_flags
758

759
  let
760
        db_to_operate_on = my_head "register" $
761
                           filter ((== to_modify).location) db_stack
762
  --
763 764 765
  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
766
  s <-
767
    case input of
sof's avatar
sof committed
768
      "-" -> do
769
        when (verbosity >= Normal) $
770
            info "Reading package info from stdin ... "
771 772
        -- fix the encoding to UTF-8, since this is an interchange format
        hSetEncoding stdin utf8
sof's avatar
sof committed
773 774
        getContents
      f   -> do
775
        when (verbosity >= Normal) $
776
            info ("Reading package info from " ++ show f ++ " ... ")
777
        readUTF8File f
778

779 780
  expanded <- if expand_env_vars then expandEnvVars s force
                                 else return s
781

782
  (pkg, ws) <- parsePackageInfo expanded
783
  when (verbosity >= Normal) $
784
      infoLn "done."
785

786 787 788 789
  -- report any warnings from the parse phase
  _ <- reportValidateErrors [] ws
         (display (sourcePackageId pkg) ++ ": Warning: ") Nothing

790 791 792 793 794
  -- 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

795
  let truncated_stack = dropWhile ((/= to_modify).location) db_stack
796 797
  -- truncate the stack for validation, because we don't allow
  -- packages lower in the stack to refer to those higher up.
798
  validatePackageConfig pkg_expanded verbosity truncated_stack auto_ghci_libs update force
799 800 801 802 803 804
  let 
     removes = [ RemovePackage p
               | p <- packages db_to_operate_on,
                 sourcePackageId p == sourcePackageId pkg ]
  --
  changeDB verbosity (removes ++ [AddPackage pkg]) db_to_operate_on
805 806

parsePackageInfo
Ian Lynagh's avatar
Ian Lynagh committed
807
        :: String
808
        -> IO (InstalledPackageInfo, [ValidateWarning])
809
parsePackageInfo str =
810
  case parseInstalledPackageInfo str of
811 812 813 814
    ParseOk warnings ok -> return (ok, ws)
      where
        ws = [ msg | PWarning msg <- warnings
                   , not ("Unrecognized field pkgroot" `isPrefixOf` msg) ]
815 816 817
    ParseFailed err -> case locatedErrorMsg err of
                           (Nothing, s) -> die s
                           (Just l, s) -> die (show l ++ ": " ++ s)
818

819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852
-- -----------------------------------------------------------------------------
-- 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"
853
    when (verbosity > Normal) $ infoLn ("removing " ++ file)
854
    removeFileSafe file
855 856
  do_cmd (AddPackage p) = do
    let file = location db </> display (installedPackageId p) <.> "conf"
857
    when (verbosity > Normal) $ infoLn ("writing " ++ file)
Ian Lynagh's avatar
Ian Lynagh committed
858
    writeFileUtf8Atomic file (showInstalledPackageInfo p)
859 860 861 862 863 864 865
  do_cmd (ModifyPackage p) = 
    do_cmd (AddPackage p)

updateDBCache :: Verbosity -> PackageDB -> IO ()
updateDBCache verbosity db = do
  let filename = location db </> cachefilename
  when (verbosity > Normal) $
866
      infoLn ("writing cache " ++ filename)
867
  writeBinaryFileAtomic filename (map convertPackageInfoOut (packages db))