Main.hs 63.6 KB
Newer Older
1
{-# OPTIONS -fglasgow-exts -cpp #-}
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
Simon Marlow's avatar
Simon Marlow committed
22
import System.FilePath
23
import System.Cmd       ( rawSystem )
24
25
26
import System.Directory ( getAppUserDataDirectory, createDirectoryIfMissing,
                          getModificationTime )
import Text.Printf
27

28
import Prelude
29

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

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

45
46
47
48
import qualified Data.ByteString.Lazy as B
import qualified Data.Binary as Bin
import qualified Data.Binary.Get as Bin

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

#if __GLASGOW_HASKELL__ < 612
56
57
58
59
import System.Posix.Internals
import GHC.Handle (fdToHandle)
#endif

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

Ian Lynagh's avatar
Ian Lynagh committed
66
import IO ( isPermissionError )
Ian Lynagh's avatar
Ian Lynagh committed
67

68
69
70
71
72
#if defined(GLOB)
import System.Process(runInteractiveCommand)
import qualified System.Info(os)
#endif

73
#if !defined(mingw32_HOST_OS) && __GLASGOW_HASKELL__ >= 611 && !defined(BOOTSTRAPPING)
74
75
76
import System.Console.Terminfo as Terminfo
#endif

77
78
79
-- -----------------------------------------------------------------------------
-- Entry point

80
main :: IO ()
81
82
83
main = do
  args <- getArgs

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

98
99
-- -----------------------------------------------------------------------------
-- Command-line syntax
100

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

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

150
151
152
153
154
155
156
157
158
159
160
161
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

162
163
deprecFlags :: [OptDescr Flag]
deprecFlags = [
164
        -- put deprecated flags here
165
  ]
166
167

ourCopyright :: String
168
ourCopyright = "GHC package manager version " ++ Version.version ++ "\n"
169
170
171
172

usageHeader :: String -> String
usageHeader prog = substProg prog $
  "Usage:\n" ++
173
174
175
176
177
178
  "  $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" ++
179
  "  $p register {filename | -}\n" ++
180
181
  "    Register the package using the specified installed package\n" ++
  "    description. The syntax for the latter is given in the $p\n" ++
182
  "    documentation.  The input file should be encoded in UTF-8.\n" ++
183
  "\n" ++
184
185
  "  $p update {filename | -}\n" ++
  "    Register the package, overwriting any other package with the\n" ++
186
  "    same name. The input file should be encoded in UTF-8.\n" ++
187
  "\n" ++
188
189
190
191
192
193
194
195
196
  "  $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" ++
197
198
199
  "  $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
200
  "    all the registered versions will be listed in ascending order.\n" ++
201
202
  "    Accepts the --simple-output flag.\n" ++
  "\n" ++
203
204
205
206
207
  "  $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" ++
208
209
  "  $p find-module {module}\n" ++
  "    List registered packages exposing module {module} in the global\n" ++
Ian Lynagh's avatar
Ian Lynagh committed
210
  "    database, and also the user database if --user is given.\n" ++
211
  "    All the registered versions will be listed in ascending order.\n" ++
212
  "    Accepts the --simple-output flag.\n" ++
213
  "\n" ++
214
  "  $p latest {pkg-id}\n" ++
215
  "    Prints the highest registered version of a package.\n" ++
216
  "\n" ++
217
218
219
220
  "  $p check\n" ++
  "    Check the consistency of package depenencies and list broken packages.\n" ++
  "    Accepts the --simple-output flag.\n" ++
  "\n" ++
221
  "  $p describe {pkg}\n" ++
222
223
224
225
  "    Give the registered description for the specified package. The\n" ++
  "    description is returned in precisely the syntax required by $p\n" ++
  "    register.\n" ++
  "\n" ++
226
  "  $p field {pkg} {field}\n" ++
227
  "    Extract the specified field of the package description for the\n" ++
228
229
  "    specified package. Accepts comma-separated multiple fields.\n" ++
  "\n" ++
230
231
232
  "  $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" ++
233
234
  "    by tools that parse the results, rather than humans.  The output is\n" ++
  "    always encoded in UTF-8, regardless of the current locale.\n" ++
235
  "\n" ++
236
237
238
239
240
241
242
  "  $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" ++
243
244
245
  " 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" ++
246
  "\n" ++
247
248
249
250
251
252
253
  "  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"++
254
  "  Commands that query the package database (list, tree, latest, describe,\n"++
255
256
257
258
  "  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" ++
259
  " The following optional flags are also accepted:\n"
260
261
262
263
264
265
266
267
268

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
269
270
data Force = NoForce | ForceFiles | ForceAll | CannotForce
  deriving (Eq,Ord)
271

272
273
data PackageArg = Id PackageIdentifier | Substring String (String->Bool)

274
275
runit :: Verbosity -> [Flag] -> [String] -> IO ()
runit verbosity cli nonopts = do
276
  installSignalHandlers -- catch ^C and clean up
277
278
  prog <- getProgramName
  let
Ian Lynagh's avatar
Ian Lynagh committed
279
280
        force
          | FlagForce `elem` cli        = ForceAll
281
282
          | FlagForceFiles `elem` cli   = ForceFiles
          | otherwise                   = NoForce
Ian Lynagh's avatar
Ian Lynagh committed
283
        auto_ghci_libs = FlagAutoGHCiLibs `elem` cli
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
        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
308
309
310
  --
  -- first, parse the command
  case nonopts of
311
312
313
314
315
316
317
318
319
#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
320
321
    ["init", filename] ->
        initPackageDB filename verbosity cli
Ian Lynagh's avatar
Ian Lynagh committed
322
    ["register", filename] ->
323
        registerPackage filename verbosity cli auto_ghci_libs False force
Ian Lynagh's avatar
Ian Lynagh committed
324
    ["update", filename] ->
325
        registerPackage filename verbosity cli auto_ghci_libs True force
326
    ["unregister", pkgid_str] -> do
Ian Lynagh's avatar
Ian Lynagh committed
327
        pkgid <- readGlobPkgId pkgid_str
328
        unregisterPackage pkgid verbosity cli force
329
    ["expose", pkgid_str] -> do
Ian Lynagh's avatar
Ian Lynagh committed
330
        pkgid <- readGlobPkgId pkgid_str
331
        exposePackage pkgid verbosity cli force
332
    ["hide",   pkgid_str] -> do
Ian Lynagh's avatar
Ian Lynagh committed
333
        pkgid <- readGlobPkgId pkgid_str
334
        hidePackage pkgid verbosity cli force
335
    ["list"] -> do
336
        listPackages verbosity cli Nothing Nothing
337
338
339
    ["list", pkgid_str] ->
        case substringCheck pkgid_str of
          Nothing -> do pkgid <- readGlobPkgId pkgid_str
340
341
342
343
                        listPackages verbosity cli (Just (Id pkgid)) Nothing
          Just m -> listPackages verbosity cli (Just (Substring pkgid_str m)) Nothing
    ["dot"] -> do
        showPackageDot verbosity cli
344
    ["find-module", moduleName] -> do
345
        let match = maybe (==moduleName) id (substringCheck moduleName)
346
        listPackages verbosity cli Nothing (Just match)
347
    ["latest", pkgid_str] -> do
Ian Lynagh's avatar
Ian Lynagh committed
348
        pkgid <- readGlobPkgId pkgid_str
349
        latestPackage verbosity cli pkgid
350
351
352
    ["describe", pkgid_str] ->
        case substringCheck pkgid_str of
          Nothing -> do pkgid <- readGlobPkgId pkgid_str
353
354
                        describePackage verbosity cli (Id pkgid)
          Just m -> describePackage verbosity cli (Substring pkgid_str m)
355
356
357
    ["field", pkgid_str, fields] ->
        case substringCheck pkgid_str of
          Nothing -> do pkgid <- readGlobPkgId pkgid_str
358
359
360
                        describeField verbosity cli (Id pkgid) 
                                      (splitFields fields)
          Just m -> describeField verbosity cli (Substring pkgid_str m)
361
                                      (splitFields fields)
362
    ["check"] -> do
363
        checkConsistency verbosity cli
364
365

    ["dump"] -> do
366
367
368
369
        dumpPackages verbosity cli

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

371
    [] -> do
Ian Lynagh's avatar
Ian Lynagh committed
372
373
        die ("missing command\n" ++
                usageInfo (usageHeader prog) flags)
374
    (_cmd:_) -> do
Ian Lynagh's avatar
Ian Lynagh committed
375
376
        die ("command-line syntax error\n" ++
                usageInfo (usageHeader prog) flags)
377
378

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

384
385
386
387
readGlobPkgId :: String -> IO PackageIdentifier
readGlobPkgId str = parseCheck parseGlobPackageId str "package identifier"

parseGlobPackageId :: ReadP r PackageIdentifier
Ian Lynagh's avatar
Ian Lynagh committed
388
parseGlobPackageId =
389
  parse
390
     +++
Ian Lynagh's avatar
Ian Lynagh committed
391
  (do n <- parse
392
      _ <- string "-*"
393
394
395
      return (PackageIdentifier{ pkgName = n, pkgVersion = globVersion }))

-- globVersion means "all versions"
396
globVersion :: Version
397
398
globVersion = Version{ versionBranch=[], versionTags=["*"] }

399
400
401
402
-- -----------------------------------------------------------------------------
-- Package databases

-- Some commands operate on a single database:
Ian Lynagh's avatar
Ian Lynagh committed
403
--      register, unregister, expose, hide
404
405
406
407
408
-- 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
409
--      list, describe, field
410

411
412
413
data PackageDB 
  = PackageDB { location :: FilePath,
                packages :: [InstalledPackageInfo] }
414

415
type PackageDBStack = [PackageDB]
Ian Lynagh's avatar
Ian Lynagh committed
416
        -- A stack of package databases.  Convention: head is the topmost
417
        -- in the stack.
418

419
allPackagesInStack :: PackageDBStack -> [InstalledPackageInfo]
420
allPackagesInStack = concatMap packages
421

422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
getPkgDatabases :: Verbosity
                -> Bool    -- we are modifying, not reading
                -> Bool    -- read caches, if available
                -> [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'.

getPkgDatabases verbosity modify use_cache my_flags = do
438
439
440
441
442
  -- 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
443
  global_conf <-
444
     case [ f | FlagGlobalConfig f <- my_flags ] of
Ian Lynagh's avatar
Ian Lynagh committed
445
        [] -> do mb_dir <- getLibDir
Ian Lynagh's avatar
Ian Lynagh committed
446
                 case mb_dir of
447
448
449
450
451
452
                   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
453
454
        fs -> return (last fs)

Simon Marlow's avatar
Simon Marlow committed
455
456
  let no_user_db = FlagNoUserDb `elem` my_flags

457
  -- get the location of the user package database, and create it if necessary
458
  -- getAppUserDataDirectory can fail (e.g. if $HOME isn't set)
459
  e_appdir <- try $ getAppUserDataDirectory "ghc"
460
461

  mb_user_conf <-
Simon Marlow's avatar
Simon Marlow committed
462
     if no_user_db then return Nothing else
463
464
465
466
467
468
469
470
471
     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))
472

473
474
475
  -- 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
476
        | Just (user_conf,user_exists) <- mb_user_conf,
477
478
          modify || user_exists = [user_conf, global_conf]
        | otherwise             = [global_conf]
479

480
  e_pkg_path <- try (System.Environment.getEnv "GHC_PACKAGE_PATH")
481
  let env_stack =
Ian Lynagh's avatar
Ian Lynagh committed
482
483
484
485
486
        case e_pkg_path of
                Left  _ -> sys_databases
                Right path
                  | last cs == ""  -> init cs ++ sys_databases
                  | otherwise      -> cs
487
                  where cs = parseSearchPath path
Ian Lynagh's avatar
Ian Lynagh committed
488
489
490

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

493
  let db_flags = [ f | Just f <- map is_db_flag my_flags ]
494
         where is_db_flag FlagUser
Ian Lynagh's avatar
Ian Lynagh committed
495
                      | Just (user_conf, _user_exists) <- mb_user_conf 
496
                      = Just user_conf
497
498
499
               is_db_flag FlagGlobal     = Just virt_global_conf
               is_db_flag (FlagConfig f) = Just f
               is_db_flag _              = Nothing
500

501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
  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)

  db_stack <- mapM (readParseDatabase verbosity mb_user_conf use_cache) final_stack

  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
547
  -- the user database (only) is allowed to be non-existent
548
549
  | Just (user_conf,False) <- mb_user_conf, path == user_conf
  = return PackageDB { location = path, packages = [] }
550
  | otherwise
551
552
553
554
555
556
557
558
559
560
561
562
563
564
  = do e <- try $ getDirectoryContents path
       case e of
         Left _   -> do
              pkgs <- parseMultiPackageConf verbosity path
              return PackageDB{ location = path, packages = pkgs }              
         Right fs
           | not use_cache -> ignore_cache
           | otherwise -> do
              let cache = path </> cachefilename
              tdir     <- getModificationTime path
              e_tcache <- try $ getModificationTime cache
              case e_tcache of
                Left ex -> do
                     when (verbosity > Normal) $
565
                        warn ("warning: cannot read cache file " ++ cache ++ ": " ++ show ex)
566
567
568
569
570
                     ignore_cache
                Right tcache
                  | tcache >= tdir -> do
                     when (verbosity > Normal) $
                        putStrLn ("using cache: " ++ cache)
571
                     pkgs <- myReadBinPackageDB cache
572
573
574
575
                     let pkgs' = map convertPackageInfoIn pkgs
                     return PackageDB { location = path, packages = pkgs' }
                  | otherwise -> do
                     when (verbosity >= Normal) $ do
576
577
                        warn ("WARNING: cache is out of date: " ++ cache)
                        warn "  use 'ghc-pkg recache' to fix."
578
579
580
581
582
583
584
585
                     ignore_cache
            where
                 ignore_cache = do
                     let confs = filter (".conf" `isSuffixOf`) fs
                     pkgs <- mapM (parseSingletonPackageConf verbosity) $
                                   map (path </>) confs
                     return PackageDB { location = path, packages = pkgs }

586
587
588
589
590
591
592
593
594
595
596
-- 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
597
598
599
600

parseMultiPackageConf :: Verbosity -> FilePath -> IO [InstalledPackageInfo]
parseMultiPackageConf verbosity file = do
  when (verbosity > Normal) $ putStrLn ("reading package database: " ++ file)
601
  str <- readUTF8File file
602
603
604
605
606
607
608
609
  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)
610
  readUTF8File file >>= parsePackageInfo
611
612
613

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

615
616
617
618
619
620
621
622
623
624
625
626
-- -----------------------------------------------------------------------------
-- 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
  changeDB verbosity [] PackageDB{ location = filename, packages = [] }

627
628
629
630
-- -----------------------------------------------------------------------------
-- Registering

registerPackage :: FilePath
631
                -> Verbosity
Ian Lynagh's avatar
Ian Lynagh committed
632
633
634
635
636
                -> [Flag]
                -> Bool              -- auto_ghci_libs
                -> Bool              -- update
                -> Force
                -> IO ()
637
registerPackage input verbosity my_flags auto_ghci_libs update force = do
638
639
640
  (db_stack, Just to_modify, _flag_dbs) <- 
      getPkgDatabases verbosity True True my_flags

641
  let
642
        db_to_operate_on = my_head "register" $
643
                           filter ((== to_modify).location) db_stack
644
  --
sof's avatar
sof committed
645
  s <-
646
    case input of
sof's avatar
sof committed
647
      "-" -> do
648
649
        when (verbosity >= Normal) $
            putStr "Reading package info from stdin ... "
650
651
652
653
#if __GLASGOW_HASKELL__ >= 612
        -- fix the encoding to UTF-8, since this is an interchange format
        hSetEncoding stdin utf8
#endif
sof's avatar
sof committed
654
655
        getContents
      f   -> do
656
657
        when (verbosity >= Normal) $
            putStr ("Reading package info from " ++ show f ++ " ... ")
658
        readUTF8File f
659

660
  expanded <- expandEnvVars s force
661

662
  pkg <- parsePackageInfo expanded
663
664
  when (verbosity >= Normal) $
      putStrLn "done."
665

666
  let truncated_stack = dropWhile ((/= to_modify).location) db_stack
667
668
669
  -- truncate the stack for validation, because we don't allow
  -- packages lower in the stack to refer to those higher up.
  validatePackageConfig pkg truncated_stack auto_ghci_libs update force
670
671
672
673
674
675
  let 
     removes = [ RemovePackage p
               | p <- packages db_to_operate_on,
                 sourcePackageId p == sourcePackageId pkg ]
  --
  changeDB verbosity (removes ++ [AddPackage pkg]) db_to_operate_on
676
677

parsePackageInfo
Ian Lynagh's avatar
Ian Lynagh committed
678
679
        :: String
        -> IO InstalledPackageInfo
680
parsePackageInfo str =
681
  case parseInstalledPackageInfo str of
682
    ParseOk _warns ok -> return ok
683
684
685
    ParseFailed err -> case locatedErrorMsg err of
                           (Nothing, s) -> die s
                           (Just l, s) -> die (show l ++ ": " ++ s)
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
713
714
715
716
717
718
719
720
721
722
723
724
725
-- -----------------------------------------------------------------------------
-- 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)
    removeFile file
  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
726
    writeFileUtf8Atomic file (showInstalledPackageInfo p)
727
728
729
730
731
732
733
734
  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)
735
  writeBinaryFileAtomic filename (map convertPackageInfoOut (packages db))
736
737
738
739
740
    `catch` \e ->
      if isPermissionError e
      then die (filename ++ ": you don't have permission to modify this file")
      else ioError e

741
-- -----------------------------------------------------------------------------
742
-- Exposing, Hiding, Unregistering are all similar
743

744
exposePackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO ()
745
exposePackage = modifyPackage (\p -> ModifyPackage p{exposed=True})
746

747
hidePackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO ()
748
hidePackage = modifyPackage (\p -> ModifyPackage p{exposed=False})
749

750
unregisterPackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO ()
751
unregisterPackage = modifyPackage RemovePackage
752
753

modifyPackage
754
  :: (InstalledPackageInfo -> DBOp)
755
  -> PackageIdentifier
756
  -> Verbosity
757
  -> [Flag]
758
  -> Force
759
  -> IO ()
760
modifyPackage fn pkgid verbosity my_flags force = do
761
762
763
764
  (db_stack, Just _to_modify, _flag_dbs) <- 
      getPkgDatabases verbosity True{-modify-} True{-use cache-} my_flags

  (db, ps) <- fmap head $ findPackagesByDB db_stack (Id pkgid)
765
  let 
766
767
768
      db_name = location db
      pkgs    = packages db

769
      pids = map sourcePackageId ps
770

771
772
773
      cmds = [ fn pkg | pkg <- pkgs, sourcePackageId pkg `elem` pids ]
      new_db = updateInternalDB db cmds

774
      old_broken = brokenPackages (allPackagesInStack db_stack)
775
776
      rest_of_stack = filter ((/= db_name) . location) db_stack
      new_stack = new_db : rest_of_stack
777
778
      new_broken = map sourcePackageId (brokenPackages (allPackagesInStack new_stack))
      newly_broken = filter (`notElem` map sourcePackageId old_broken) new_broken
779
  --
780
781
782
783
784
  when (not (null newly_broken)) $
      dieOrForceAll force ("unregistering " ++ display pkgid ++
           " would break the following packages: "
              ++ unwords (map display newly_broken))

785
786
787
788
789
790
791
792
793
794
795
  changeDB verbosity cmds db

recache :: Verbosity -> [Flag] -> IO ()
recache verbosity my_flags = do
  (db_stack, Just to_modify, _flag_dbs) <- 
     getPkgDatabases verbosity True{-modify-} False{-no cache-} my_flags
  let
        db_to_operate_on = my_head "recache" $
                           filter ((== to_modify).location) db_stack
  --
  changeDB verbosity [] db_to_operate_on
796
797
798
799

-- -----------------------------------------------------------------------------
-- Listing packages

800
801
802
803
listPackages ::  Verbosity -> [Flag] -> Maybe PackageArg
             -> Maybe (String->Bool)
             -> IO ()
listPackages verbosity my_flags mPackageName mModuleName = do
804
  let simple_output = FlagSimpleOutput `elem` my_flags
805
806
807
  (db_stack, _, flag_db_stack) <- 
     getPkgDatabases verbosity False True{-use cache-} my_flags

808
809
  let db_stack_filtered -- if a package is given, filter out all other packages
        | Just this <- mPackageName =
810
811
            [ db{ packages = filter (this `matchesPkg`) (packages db) }
            | db <- flag_db_stack ]
812
        | Just match <- mModuleName = -- packages which expose mModuleName
813
814
815
            [ db{ packages = filter (match `exposedInPkg`) (packages db) }
            | db <- flag_db_stack ]
        | otherwise = flag_db_stack
816

Ian Lynagh's avatar
Ian Lynagh committed
817
      db_stack_sorted
818
819
          = [ db{ packages = sort_pkgs (packages db) }
            | db <- db_stack_filtered ]
Ian Lynagh's avatar
Ian Lynagh committed
820
821
822
823
824
825
          where sort_pkgs = sortBy cmpPkgIds
                cmpPkgIds pkg1 pkg2 =
                   case pkgName p1 `compare` pkgName p2 of
                        LT -> LT
                        GT -> GT
                        EQ -> pkgVersion p1 `compare` pkgVersion p2
826
                   where (p1,p2) = (sourcePackageId pkg1, sourcePackageId pkg2)
827

828
829
      stack = reverse db_stack_sorted

Ian Lynagh's avatar
Ian Lynagh committed
830
      match `exposedInPkg` pkg = any match (map display $ exposedModules pkg)
831

832
      pkg_map = allPackagesInStack db_stack
833
      broken = map sourcePackageId (brokenPackages pkg_map)
834

835
836
837
838
      show_normal PackageDB{ location = db_name, packages = pkg_confs } =
          hPutStrLn stdout $ unlines ((db_name ++ ":") : map ("    " ++) pp_pkgs)
           where
                 pp_pkgs = map pp_pkg pkg_confs
Ian Lynagh's avatar
Ian Lynagh committed
839
                 pp_pkg p
840
                   | sourcePackageId p `elem` broken = printf "{%s}" doc
Ian Lynagh's avatar
Ian Lynagh committed
841
                   | exposed p = doc
842
843
                   | otherwise = printf "(%s)" doc
                   where doc | verbosity >= Verbose = printf "%s (%s)" pkg ipid
844
845
                             | otherwise            = pkg
                          where
846
847
                          InstalledPackageId ipid = installedPackageId p
                          pkg = display (sourcePackageId p)
848
849

      show_simple = simplePackageList my_flags . allPackagesInStack
850

851
  when (not (null broken) && not simple_output && verbosity /= Silent) $ do
852
     prog <- getProgramName
853
     warn ("WARNING: there are broken packages.  Run '" ++ prog ++ " check' for more details.")
854

855
856
  if simple_output then show_simple stack else do

857
#if defined(mingw32_HOST_OS) || __GLASGOW_HASKELL__ < 611 || defined(BOOTSTRAPPING)
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
886
  mapM_ show_normal stack
#else
  let
     show_colour withF db =
         mconcat $ map (<#> termText "\n") $
             (termText (location db) :
                map (termText "   " <#>) (map pp_pkg (packages db)))
        where
                 pp_pkg p
                   | sourcePackageId p `elem` broken = withF Red  doc
                   | exposed p                       = doc
                   | otherwise                       = withF Blue doc
                   where doc | verbosity >= Verbose
                             = termText (printf "%s (%s)" pkg ipid)
                             | otherwise
                             = termText pkg
                          where
                          InstalledPackageId ipid = installedPackageId p
                          pkg = display (sourcePackageId p)

  is_tty <- hIsTerminalDevice stdout
  if not is_tty
     then mapM_ show_normal stack
     else do tty <- Terminfo.setupTermFromEnv
             case Terminfo.getCapability tty withForegroundColor of
                 Nothing -> mapM_ show_normal stack
                 Just w  -> runTermOutput tty $ mconcat $
                                                map (show_colour w) stack
#endif
Simon Marlow's avatar
Simon Marlow committed
887
888
889
890
891

simplePackageList :: [Flag] -> [InstalledPackageInfo] -> IO ()
simplePackageList my_flags pkgs = do
   let showPkg = if FlagNamesOnly `elem` my_flags then display . pkgName
                                                  else display
892
       strs = map showPkg $ sortBy compPkgIdVer $ map sourcePackageId pkgs
Simon Marlow's avatar
Simon Marlow committed
893
894
   when (not (null pkgs)) $
      hPutStrLn stdout $ concat $ intersperse " " strs
895

896
showPackageDot :: Verbosity -> [Flag] -> IO ()
897
898
899
900
901
showPackageDot verbosity myflags = do
  (_, _, flag_db_stack) <- 
      getPkgDatabases verbosity False True{-use cache-} myflags

  let all_pkgs = allPackagesInStack flag_db_stack
902
      ipix  = PackageIndex.fromList all_pkgs
903
904
905
906
907

  putStrLn "digraph {"
  let quote s = '"':s ++ "\""
  mapM_ putStrLn [ quote from ++ " -> " ++ quote to
                 | p <- all_pkgs,
908
                   let from = display (sourcePackageId p),
909
                   depid <- depends p,
910
                   Just dep <- [PackageIndex.lookupInstalledPackageId ipix depid],
911
                   let to = display (sourcePackageId dep)
912
913
914
                 ]
  putStrLn "}"

915
916
917
-- -----------------------------------------------------------------------------
-- Prints the highest (hidden or exposed) version of a package

918
919
920
921
922
923
latestPackage ::  Verbosity -> [Flag] -> PackageIdentifier -> IO ()
latestPackage verbosity my_flags pkgid = do
  (_, _, flag_db_stack) <- 
     getPkgDatabases verbosity False True{-use cache-} my_flags

  ps <- findPackages flag_db_stack (Id pkgid)
924
  show_pkg (sortBy compPkgIdVer (map sourcePackageId ps))
925
926
  where
    show_pkg [] = die "no matches"
927
    show_pkg pids = hPutStrLn stdout (display (last pids))
928
929
930
931

-- -----------------------------------------------------------------------------
-- Describe

932
933
934
935
936
describePackage :: Verbosity -> [Flag] -> PackageArg -> IO ()
describePackage verbosity my_flags pkgarg = do
  (_, _, flag_db_stack) <- 
      getPkgDatabases verbosity False True{-use cache-} my_flags
  ps <- findPackages flag_db_stack pkgarg
937
938
  doDump ps

939
940
941
942
943
dumpPackages :: Verbosity -> [Flag] -> IO ()
dumpPackages verbosity my_flags = do
  (_, _, flag_db_stack) <- 
     getPkgDatabases verbosity False True{-use cache-} my_flags
  doDump (allPackagesInStack flag_db_stack)
944
945

doDump :: [InstalledPackageInfo] -> IO ()
946
947
948
949
950
951
doDump pkgs = do
#if __GLASGOW_HASKELL__ >= 612
  -- fix the encoding to UTF-8, since this is an interchange format
  hSetEncoding stdout utf8
#endif
  mapM_ putStrLn . intersperse "---" . map showInstalledPackageInfo $ pkgs
952

953
-- PackageId is can have globVersion for the version
954
955
findPackages :: PackageDBStack -> PackageArg -> IO [InstalledPackageInfo]
findPackages db_stack pkgarg
956
957
958
  = fmap (concatMap snd) $ findPackagesByDB db_stack pkgarg

findPackagesByDB :: PackageDBStack -> PackageArg
959
                 -> IO [(PackageDB, [InstalledPackageInfo])]
960
961
findPackagesByDB db_stack pkgarg
  = case [ (db, matched)
962
963
         | db <- db_stack,
           let matched = filter (pkgarg `matchesPkg`) (packages db),
964
965
           not (null matched) ] of
        [] -> die ("cannot find package " ++ pkg_msg pkgarg)
Ian Lynagh's avatar
Ian Lynagh committed
966
        ps -> return ps
967
  where
968
        pkg_msg (Id pkgid)           = display pkgid
969
        pkg_msg (Substring pkgpat _) = "matching " ++ pkgpat
970

971
972
973
974
975
matches :: PackageIdentifier -> PackageIdentifier -> Bool
pid `matches` pid'
  = (pkgName pid == pkgName pid')
    && (pkgVersion pid == pkgVersion pid' || not (realVersion pid))

976
977
978
979
realVersion :: PackageIdentifier -> Bool
realVersion pkgid = versionBranch (pkgVersion pkgid) /= []
  -- when versionBranch == [], this is a glob

980
matchesPkg :: PackageArg -> InstalledPackageInfo -> Bool
981
982
(Id pid)        `matchesPkg` pkg = pid `matches` sourcePackageId pkg
(Substring _ m) `matchesPkg` pkg = m (display (sourcePackageId pkg))
983
984
985
986

compPkgIdVer :: PackageIdentifier -> PackageIdentifier -> Ordering
compPkgIdVer p1 p2 = pkgVersion p1 `compare` pkgVersion p2

987
988
989
-- -----------------------------------------------------------------------------
-- Field

990
991
992
993
describeField :: Verbosity -> [Flag] -> PackageArg -> [String] -> IO ()
describeField verbosity my_flags pkgarg fields = do
  (_, _, flag_db_stack) <- 
      getPkgDatabases verbosity False True{-use cache-} my_flags
994
  fns <- toFields fields
995
996
  ps <- findPackages flag_db_stack pkgarg
  let top_dir = takeDirectory (location (last flag_db_stack))
997
998
999
1000
1001
1002
1003
  mapM_ (selectFields fns) (mungePackagePaths top_dir ps)
  where toFields [] = return []
        toFields (f:fs) = case toField f of
            Nothing -> die ("unknown field: " ++ f)
            Just fn -> do fns <- toFields fs
                          return (fn:fns)
        selectFields fns info = mapM_ (\fn->putStrLn (fn info)) fns
1004
1005

mungePackagePaths :: String -> [InstalledPackageInfo] -> [InstalledPackageInfo]
Ian Lynagh's avatar
Ian Lynagh committed
1006
-- Replace the strings "$topdir" and "$httptopdir" at the beginning of a path
1007
1008
1009
1010
-- with the current topdir (obtained from the -B option).
mungePackagePaths top_dir ps = map munge_pkg ps
  where
  munge_pkg p = p{ importDirs        = munge_paths (importDirs p),
Ian Lynagh's avatar
Ian Lynagh committed
1011
1012
1013
1014
1015
                   includeDirs       = munge_paths (includeDirs p),
                   libraryDirs       = munge_paths (libraryDirs p),
                   frameworkDirs     = munge_paths (frameworkDirs p),
                   haddockInterfaces = munge_paths (haddockInterfaces p),
                   haddockHTMLs      = munge_paths (haddockHTMLs p)
1016
1017
1018
1019
                 }

  munge_paths = map munge_path

Ian Lynagh's avatar
Ian Lynagh committed
1020
  munge_path p
Ian Lynagh's avatar
Ian Lynagh committed
1021
1022
1023
1024
1025
   | Just p' <- maybePrefixMatch "$topdir"     p =            top_dir ++ p'