Main.hs 70 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.Process
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 Data.Ord (comparing)
37
import Control.Monad
38
import System.Directory ( doesDirectoryExist, getDirectoryContents,
39 40
                          doesFileExist, renameFile, removeFile,
                          getCurrentDirectory )
41 42
import System.Exit ( exitWith, ExitCode(..) )
import System.Environment ( getArgs, getProgName, getEnv )
43
import System.IO
44
import System.IO.Error
45
import Data.List
46
import Control.Concurrent
47

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

52
#if defined(mingw32_HOST_OS)
53
-- mingw32 needs these for getExecDir
54
import Foreign
Simon Marlow's avatar
Simon Marlow committed
55
import Foreign.C
Simon Marlow's avatar
Simon Marlow committed
56 57
#endif

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

64 65 66 67
#if defined(GLOB)
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 75 76 77 78 79 80 81
#ifdef mingw32_HOST_OS
# if defined(i386_HOST_ARCH)
#  define WINDOWS_CCONV stdcall
# elif defined(x86_64_HOST_ARCH)
#  define WINDOWS_CCONV ccall
# else
#  error Unknown mingw32 arch
# endif
#endif

82 83 84
-- -----------------------------------------------------------------------------
-- Entry point

85
main :: IO ()
86 87 88
main = do
  args <- getArgs

89
  case getOpt Permute (flags ++ deprecFlags) args of
Ian Lynagh's avatar
Ian Lynagh committed
90 91 92 93 94 95
        (cli,_,[]) | FlagHelp `elem` cli -> do
           prog <- getProgramName
           bye (usageInfo (usageHeader prog) flags)
        (cli,_,[]) | FlagVersion `elem` cli ->
           bye ourCopyright
        (cli,nonopts,[]) ->
96 97 98
           case getVerbosity Normal cli of
           Right v -> runit v cli nonopts
           Left err -> die err
99
        (_,_,errors) -> do
Ian Lynagh's avatar
Ian Lynagh committed
100
           prog <- getProgramName
101
           die (concat errors ++ shortUsage prog)
102

103 104
-- -----------------------------------------------------------------------------
-- Command-line syntax
105

106 107 108 109 110
data Flag
  = FlagUser
  | FlagGlobal
  | FlagHelp
  | FlagVersion
Ian Lynagh's avatar
Ian Lynagh committed
111
  | FlagConfig FilePath
112 113
  | FlagGlobalConfig FilePath
  | FlagForce
114
  | FlagForceFiles
115
  | FlagAutoGHCiLibs
116
  | FlagExpandEnvVars
117 118
  | FlagExpandPkgroot
  | FlagNoExpandPkgroot
119
  | FlagSimpleOutput
120
  | FlagNamesOnly
121
  | FlagIgnoreCase
Simon Marlow's avatar
Simon Marlow committed
122
  | FlagNoUserDb
123
  | FlagVerbosity (Maybe String)
124
  deriving Eq
125

126
flags :: [OptDescr Flag]
127
flags = [
128
  Option [] ["user"] (NoArg FlagUser)
Ian Lynagh's avatar
Ian Lynagh committed
129
        "use the current user's package database",
130
  Option [] ["global"] (NoArg FlagGlobal)
131
        "use the global package database",
132 133 134 135 136 137
  Option ['f'] ["package-db"] (ReqArg FlagConfig "FILE/DIR")
        "use the specified package database",
  Option [] ["package-conf"] (ReqArg FlagConfig "FILE/DIR")
        "use the specified package database (DEPRECATED)",
  Option [] ["global-package-db"] (ReqArg FlagGlobalConfig "DIR")
        "location of the global package database",
138
  Option [] ["no-user-package-db"] (NoArg FlagNoUserDb)
Simon Marlow's avatar
Simon Marlow committed
139
        "never read the user package database",
140 141
  Option [] ["no-user-package-conf"] (NoArg FlagNoUserDb)
        "never read the user package database (DEPRECATED)",
142
  Option [] ["force"] (NoArg FlagForce)
Ian Lynagh's avatar
Ian Lynagh committed
143
         "ignore missing dependencies, directories, and libraries",
144
  Option [] ["force-files"] (NoArg FlagForceFiles)
Ian Lynagh's avatar
Ian Lynagh committed
145
         "ignore missing directories and libraries only",
146
  Option ['g'] ["auto-ghci-libs"] (NoArg FlagAutoGHCiLibs)
Ian Lynagh's avatar
Ian Lynagh committed
147
        "automatically build libs for GHCi (with register)",
148 149
  Option [] ["expand-env-vars"] (NoArg FlagExpandEnvVars)
        "expand environment variables (${name}-style) in input package descriptions",
150 151 152 153
  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",
154
  Option ['?'] ["help"] (NoArg FlagHelp)
Ian Lynagh's avatar
Ian Lynagh committed
155
        "display this help and exit",
156
  Option ['V'] ["version"] (NoArg FlagVersion)
Ian Lynagh's avatar
Ian Lynagh committed
157
        "output version information and exit",
158
  Option [] ["simple-output"] (NoArg FlagSimpleOutput)
159 160
        "print output in easy-to-parse format for some commands",
  Option [] ["names-only"] (NoArg FlagNamesOnly)
161 162
        "only print package names, not versions; can only be used with list --simple-output",
  Option [] ["ignore-case"] (NoArg FlagIgnoreCase)
163 164 165
        "ignore case for substring matching",
  Option ['v'] ["verbose"] (OptArg FlagVerbosity "Verbosity")
        "verbosity level (0-2, default 1)"
166
  ]
167

168 169 170 171 172 173 174 175 176 177 178 179
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

180 181
deprecFlags :: [OptDescr Flag]
deprecFlags = [
182
        -- put deprecated flags here
183
  ]
184 185

ourCopyright :: String
186
ourCopyright = "GHC package manager version " ++ Version.version ++ "\n"
187

188 189 190
shortUsage :: String -> String
shortUsage prog = "For usage information see '" ++ prog ++ " --help'."

191 192 193
usageHeader :: String -> String
usageHeader prog = substProg prog $
  "Usage:\n" ++
194 195 196
  "  $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" ++
197 198
  "    command with --package-db={path}.  To use the new database with GHC,\n" ++
  "    use GHC's -package-db flag.\n" ++
199
  "\n" ++
200
  "  $p register {filename | -}\n" ++
201 202
  "    Register the package using the specified installed package\n" ++
  "    description. The syntax for the latter is given in the $p\n" ++
203
  "    documentation.  The input file should be encoded in UTF-8.\n" ++
204
  "\n" ++
205 206
  "  $p update {filename | -}\n" ++
  "    Register the package, overwriting any other package with the\n" ++
207
  "    same name. The input file should be encoded in UTF-8.\n" ++
208
  "\n" ++
209 210 211 212 213 214 215 216 217
  "  $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" ++
218 219 220 221 222 223
  "  $p trust {pkg-id}\n" ++
  "    Trust the specified package.\n" ++
  "\n" ++
  "  $p distrust {pkg-id}\n" ++
  "    Distrust the specified package.\n" ++
  "\n" ++
224 225 226
  "  $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
227
  "    all the registered versions will be listed in ascending order.\n" ++
228 229
  "    Accepts the --simple-output flag.\n" ++
  "\n" ++
230 231 232 233 234
  "  $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" ++
235 236
  "  $p find-module {module}\n" ++
  "    List registered packages exposing module {module} in the global\n" ++
Ian Lynagh's avatar
Ian Lynagh committed
237
  "    database, and also the user database if --user is given.\n" ++
238
  "    All the registered versions will be listed in ascending order.\n" ++
239
  "    Accepts the --simple-output flag.\n" ++
240
  "\n" ++
241
  "  $p latest {pkg-id}\n" ++
242
  "    Prints the highest registered version of a package.\n" ++
243
  "\n" ++
244
  "  $p check\n" ++
245
  "    Check the consistency of package dependencies and list broken packages.\n" ++
246 247
  "    Accepts the --simple-output flag.\n" ++
  "\n" ++
248
  "  $p describe {pkg}\n" ++
249 250 251 252
  "    Give the registered description for the specified package. The\n" ++
  "    description is returned in precisely the syntax required by $p\n" ++
  "    register.\n" ++
  "\n" ++
253
  "  $p field {pkg} {field}\n" ++
254
  "    Extract the specified field of the package description for the\n" ++
255 256
  "    specified package. Accepts comma-separated multiple fields.\n" ++
  "\n" ++
257 258 259
  "  $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" ++
260 261
  "    by tools that parse the results, rather than humans.  The output is\n" ++
  "    always encoded in UTF-8, regardless of the current locale.\n" ++
262
  "\n" ++
263 264 265 266
  "  $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" ++
267
  "    is recached; to recache a different DB use --user or --package-db\n" ++
268 269
  "    as appropriate.\n" ++
  "\n" ++
270 271 272
  " 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" ++
273
  "\n" ++
274 275 276
  "  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"++
277
  "  or --package-db can be used to act on another database\n"++
278 279 280
  "  entirely. When multiple of these options are given, the rightmost\n"++
  "  one is used as the database to act upon.\n"++
  "\n"++
281
  "  Commands that query the package database (list, tree, latest, describe,\n"++
282
  "  field) operate on the list of databases specified by the flags\n"++
283
  "  --user, --global, and --package-db.  If none of these flags are\n"++
284 285
  "  given, the default is --global --user.\n"++
  "\n" ++
286
  " The following optional flags are also accepted:\n"
287 288 289 290 291 292 293 294 295

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
296 297
data Force = NoForce | ForceFiles | ForceAll | CannotForce
  deriving (Eq,Ord)
298

299 300
data PackageArg = Id PackageIdentifier | Substring String (String->Bool)

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

404
    ["check"] -> do
405
        checkConsistency verbosity cli
406 407

    ["dump"] -> do
408
        dumpPackages verbosity cli (fromMaybe False mexpand_pkgroot)
409 410 411

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

413
    [] -> do
414
        die ("missing command\n" ++ shortUsage prog)
415
    (_cmd:_) -> do
416
        die ("command-line syntax error\n" ++ shortUsage prog)
417 418

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

424 425 426 427
readGlobPkgId :: String -> IO PackageIdentifier
readGlobPkgId str = parseCheck parseGlobPackageId str "package identifier"

parseGlobPackageId :: ReadP r PackageIdentifier
Ian Lynagh's avatar
Ian Lynagh committed
428
parseGlobPackageId =
429
  parse
430
     +++
Ian Lynagh's avatar
Ian Lynagh committed
431
  (do n <- parse
432
      _ <- string "-*"
433 434 435
      return (PackageIdentifier{ pkgName = n, pkgVersion = globVersion }))

-- globVersion means "all versions"
436
globVersion :: Version
437 438
globVersion = Version{ versionBranch=[], versionTags=["*"] }

439 440 441 442
-- -----------------------------------------------------------------------------
-- Package databases

-- Some commands operate on a single database:
443
--      register, unregister, expose, hide, trust, distrust
444 445 446 447 448
-- 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
449
--      list, describe, field
450

451
data PackageDB 
452 453 454 455 456 457 458 459 460 461
  = 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]
    }
462

463
type PackageDBStack = [PackageDB]
Ian Lynagh's avatar
Ian Lynagh committed
464
        -- A stack of package databases.  Convention: head is the topmost
465
        -- in the stack.
466

467
allPackagesInStack :: PackageDBStack -> [InstalledPackageInfo]
468
allPackagesInStack = concatMap packages
469

470 471 472
getPkgDatabases :: Verbosity
                -> Bool    -- we are modifying, not reading
                -> Bool    -- read caches, if available
473
                -> Bool    -- expand vars, like ${pkgroot} and $topdir
474 475 476 477 478 479 480 481 482 483 484 485
                -> [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'.

486
getPkgDatabases verbosity modify use_cache expand_vars my_flags = do
487 488
  -- 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
489
  -- location is passed to the binary using the --global-package-db flag by the
490
  -- wrapper script.
491
  let err_msg = "missing --global-package-db option, location of global package database unknown\n"
Ian Lynagh's avatar
Ian Lynagh committed
492
  global_conf <-
493
     case [ f | FlagGlobalConfig f <- my_flags ] of
Ian Lynagh's avatar
Ian Lynagh committed
494
        [] -> do mb_dir <- getLibDir
Ian Lynagh's avatar
Ian Lynagh committed
495
                 case mb_dir of
496 497 498 499 500 501
                   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
502 503
        fs -> return (last fs)

504 505 506 507 508 509
  -- 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
510 511
  let no_user_db = FlagNoUserDb `elem` my_flags

512
  -- get the location of the user package database, and create it if necessary
513
  -- getAppUserDataDirectory can fail (e.g. if $HOME isn't set)
514
  e_appdir <- tryIO $ getAppUserDataDirectory "ghc"
515 516

  mb_user_conf <-
Simon Marlow's avatar
Simon Marlow committed
517
     if no_user_db then return Nothing else
518 519 520 521 522 523 524 525 526
     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))
527

528 529 530
  -- 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
531
        | Just (user_conf,user_exists) <- mb_user_conf,
532 533
          modify || user_exists = [user_conf, global_conf]
        | otherwise             = [global_conf]
534

535
  e_pkg_path <- tryIO (System.Environment.getEnv "GHC_PACKAGE_PATH")
536
  let env_stack =
Ian Lynagh's avatar
Ian Lynagh committed
537 538 539 540 541
        case e_pkg_path of
                Left  _ -> sys_databases
                Right path
                  | last cs == ""  -> init cs ++ sys_databases
                  | otherwise      -> cs
542
                  where cs = parseSearchPath path
Ian Lynagh's avatar
Ian Lynagh committed
543 544 545

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

548
  let db_flags = [ f | Just f <- map is_db_flag my_flags ]
549
         where is_db_flag FlagUser
Ian Lynagh's avatar
Ian Lynagh committed
550
                      | Just (user_conf, _user_exists) <- mb_user_conf 
551
                      = Just user_conf
552 553 554
               is_db_flag FlagGlobal     = Just virt_global_conf
               is_db_flag (FlagConfig f) = Just f
               is_db_flag _              = Nothing
555

556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577
  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)

578 579
  db_stack  <- sequence
    [ do db <- readParseDatabase verbosity mb_user_conf use_cache db_path
580 581
         if expand_vars then return (mungePackageDBPaths top_dir db)
                        else return db
582
    | db_path <- final_stack ]
583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605

  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
606
  -- the user database (only) is allowed to be non-existent
607
  | Just (user_conf,False) <- mb_user_conf, path == user_conf
608
  = mkPackageDB []
609
  | otherwise
610
  = do e <- tryIO $ getDirectoryContents path
611 612 613
       case e of
         Left _   -> do
              pkgs <- parseMultiPackageConf verbosity path
614
              mkPackageDB pkgs
615
         Right fs
616
           | not use_cache -> ignore_cache (const $ return ())
617 618 619
           | otherwise -> do
              let cache = path </> cachefilename
              tdir     <- getModificationTime path
620
              e_tcache <- tryIO $ getModificationTime cache
621 622 623
              case e_tcache of
                Left ex -> do
                     when (verbosity > Normal) $
624
                        warn ("warning: cannot read cache file " ++ cache ++ ": " ++ show ex)
625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653
                     ignore_cache (const $ return ())
                Right tcache -> do
                  let compareTimestampToCache file =
                          when (verbosity >= Verbose) $ do
                              tFile <- getModificationTime file
                              compareTimestampToCache' file tFile
                      compareTimestampToCache' file tFile = do
                          let rel = case tcache `compare` tFile of
                                    LT -> " (NEWER than cache)"
                                    GT -> " (older than cache)"
                                    EQ -> " (same as cache)"
                          warn ("Timestamp " ++ show tFile
                             ++ " for " ++ file ++ rel)
                  when (verbosity >= Verbose) $ do
                      warn ("Timestamp " ++ show tcache ++ " for " ++ cache)
                      compareTimestampToCache' path tdir
                  if tcache >= tdir
                      then do
                          when (verbosity > Normal) $
                             infoLn ("using cache: " ++ cache)
                          pkgs <- myReadBinPackageDB cache
                          let pkgs' = map convertPackageInfoIn pkgs
                          mkPackageDB pkgs'
                      else do
                          when (verbosity >= Normal) $ do
                              warn ("WARNING: cache is out of date: "
                                 ++ cache)
                              warn "Use 'ghc-pkg recache' to fix."
                          ignore_cache compareTimestampToCache
654
            where
655 656
                 ignore_cache :: (FilePath -> IO ()) -> IO PackageDB
                 ignore_cache checkTime = do
657
                     let confs = filter (".conf" `isSuffixOf`) fs
658 659 660
                         doFile f = do checkTime f
                                       parseSingletonPackageConf verbosity f
                     pkgs <- mapM doFile $ map (path </>) confs
661 662 663 664 665 666 667 668 669
                     mkPackageDB pkgs
  where
    mkPackageDB pkgs = do
      path_abs <- absolutePath path
      return PackageDB {
        location = path,
        locationAbsolute = path_abs,
        packages = pkgs
      }
670

671 672 673 674 675 676 677 678 679 680 681
-- 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
682 683 684

parseMultiPackageConf :: Verbosity -> FilePath -> IO [InstalledPackageInfo]
parseMultiPackageConf verbosity file = do
685
  when (verbosity > Normal) $ infoLn ("reading package database: " ++ file)
686
  str <- readUTF8File file
687 688 689 690 691 692 693
  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
694
  when (verbosity > Normal) $ infoLn ("reading package config: " ++ file)
695
  readUTF8File file >>= fmap fst . parsePackageInfo
696 697 698

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

700 701 702 703 704
mungePackageDBPaths :: FilePath -> PackageDB -> PackageDB
mungePackageDBPaths top_dir db@PackageDB { packages = pkgs } =
    db { packages = map (mungePackagePaths top_dir pkgroot) pkgs }
  where
    pkgroot = takeDirectory (locationAbsolute db)    
705 706 707 708
    -- 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/

709
-- TODO: This code is duplicated in compiler/main/Packages.lhs
710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726
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),
727
                     -- haddock-html is allowed to be either a URL or a file
Ian Lynagh's avatar
Ian Lynagh committed
728
      haddockHTMLs = munge_paths (munge_urls (haddockHTMLs pkg))
729 730 731 732 733 734
    }
  where
    munge_paths = map munge_path
    munge_urls  = map munge_url

    munge_path p
735 736 737
      | Just p' <- stripVarPrefix "${pkgroot}" p = pkgroot ++ p'
      | Just p' <- stripVarPrefix "$topdir"    p = top_dir ++ p'
      | otherwise                                = p
738 739

    munge_url p
740 741 742
      | Just p' <- stripVarPrefix "${pkgrooturl}" p = toUrlPath pkgroot p'
      | Just p' <- stripVarPrefix "$httptopdir"   p = toUrlPath top_dir p'
      | otherwise                                   = p
743 744 745

    toUrlPath r p = "file:///"
                 -- URLs always use posix style '/' separators:
746 747 748 749 750 751 752 753 754 755 756 757 758
                 ++ 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
759 760


761 762 763 764 765 766 767 768 769 770
-- -----------------------------------------------------------------------------
-- 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
771 772 773 774 775
  filename_abs <- absolutePath filename
  changeDB verbosity [] PackageDB {
                          location = filename, locationAbsolute = filename_abs,
                          packages = []
                        }
776

777 778 779 780
-- -----------------------------------------------------------------------------
-- Registering

registerPackage :: FilePath
781
                -> Verbosity
Ian Lynagh's avatar
Ian Lynagh committed
782 783
                -> [Flag]
                -> Bool              -- auto_ghci_libs
784
                -> Bool              -- expand_env_vars
Ian Lynagh's avatar
Ian Lynagh committed
785 786 787
                -> Bool              -- update
                -> Force
                -> IO ()
788
registerPackage input verbosity my_flags auto_ghci_libs expand_env_vars update force = do
789
  (db_stack, Just to_modify, _flag_dbs) <- 
790
      getPkgDatabases verbosity True True False{-expand vars-} my_flags
791

792
  let
793
        db_to_operate_on = my_head "register" $
794
                           filter ((== to_modify).location) db_stack
795
  --
796 797 798
  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
799
  s <-
800
    case input of
sof's avatar
sof committed
801
      "-" -> do
802
        when (verbosity >= Normal) $
803
            info "Reading package info from stdin ... "
804 805
        -- fix the encoding to UTF-8, since this is an interchange format
        hSetEncoding stdin utf8
sof's avatar
sof committed
806 807
        getContents
      f   -> do
808
        when (verbosity >= Normal) $
809
            info ("Reading package info from " ++ show f ++ " ... ")
810
        readUTF8File f
811

812 813
  expanded <- if expand_env_vars then expandEnvVars s force
                                 else return s
814

815
  (pkg, ws) <- parsePackageInfo expanded
816
  when (verbosity >= Normal) $
817
      infoLn "done."
818

819 820 821 822
  -- report any warnings from the parse phase
  _ <- reportValidateErrors [] ws
         (display (sourcePackageId pkg) ++ ": Warning: ") Nothing

823 824 825 826 827
  -- 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

828
  let truncated_stack = dropWhile ((/= to_modify).location) db_stack
829 830
  -- truncate the stack for validation, because we don't allow
  -- packages lower in the stack to refer to those higher up.
831
  validatePackageConfig pkg_expanded verbosity truncated_stack auto_ghci_libs update force
832 833 834 835 836 837
  let 
     removes = [ RemovePackage p
               | p <- packages db_to_operate_on,
                 sourcePackageId p == sourcePackageId pkg ]
  --
  changeDB verbosity (removes ++ [AddPackage pkg]) db_to_operate_on
838 839

parsePackageInfo
Ian Lynagh's avatar
Ian Lynagh committed
840
        :: String
841
        -> IO (InstalledPackageInfo, [ValidateWarning])
842
parsePackageInfo str =
843
  case parseInstalledPackageInfo str of
844 845 846 847
    ParseOk warnings ok -> return (ok, ws)
      where
        ws = [ msg | PWarning msg <- warnings
                   , not ("Unrecognized field pkgroot" `isPrefixOf` msg) ]
848 849 850
    ParseFailed err -> case locatedErrorMsg err of
                           (Nothing, s) -> die s
                           (Just l, s) -> die (show l ++ ": " ++ s)
851

852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885
-- -----------------------------------------------------------------------------
-- 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"
886
    when (verbosity > Normal) $ infoLn ("removing " ++ file)
887
    removeFileSafe file
888 889
  do_cmd (AddPackage p) = do
    let file = location db </> display (installedPackageId p) <.> "conf"
890
    when (verbosity > Normal) $ infoLn ("writing " ++ file)
Ian Lynagh's avatar
Ian Lynagh committed
891
    writeFileUtf8Atomic file (showInstalledPackageInfo p)
892 893 894 895 896 897 898
  do_cmd (ModifyPackage p) = 
    do_cmd (AddPackage p)

updateDBCache :: Verbosity -> PackageDB -> IO ()
updateDBCache verbosity db = do
  let filename = location db </> cachefilename
  when (verbosity > Normal) $
899
      infoLn ("writing cache " ++ filename)
900
  writeBinaryFileAtomic filename (map convertPackageInfoOut (packages db))
901
    `catchIO` \e ->
902