Main.hs 63 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
#include "../../includes/ghcconfig.h"
31

32
import System.Console.GetOpt
33
#if __GLASGOW_HASKELL__ >= 609
34
import qualified Control.Exception as Exception
35
36
37
#else
import qualified Control.Exception.Extensible as Exception
#endif
38
import Data.Maybe
Ian Lynagh's avatar
Ian Lynagh committed
39

40
import Data.Char ( isSpace, toLower )
41
import Control.Monad
42
import System.Directory ( doesDirectoryExist, getDirectoryContents,
43
44
45
                          doesFileExist, renameFile, removeFile )
import System.Exit ( exitWith, ExitCode(..) )
import System.Environment ( getArgs, getProgName, getEnv )
46
import System.IO
47
import System.IO.Error (try)
48
import Data.List
49
import Control.Concurrent
50

51
52
53
54
import qualified Data.ByteString.Lazy as B
import qualified Data.Binary as Bin
import qualified Data.Binary.Get as Bin

55
import Foreign
56
import Foreign.C
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

Ian Lynagh's avatar
Ian Lynagh committed
63
import IO ( isPermissionError )
64
import System.Posix.Internals
65
66
67
#if __GLASGOW_HASKELL__ >= 611
import GHC.IO.Handle.FD (fdToHandle)
#else
68
import GHC.Handle (fdToHandle)
69
#endif
Ian Lynagh's avatar
Ian Lynagh committed
70

71
72
73
74
75
#if defined(GLOB)
import System.Process(runInteractiveCommand)
import qualified System.Info(os)
#endif

76
#if !defined(mingw32_HOST_OS) && __GLASGOW_HASKELL__ >= 611 && !defined(BOOTSTRAPPING)
77
78
79
import System.Console.Terminfo as Terminfo
#endif

80
81
82
-- -----------------------------------------------------------------------------
-- Entry point

83
main :: IO ()
84
85
86
main = do
  args <- getArgs

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

101
102
-- -----------------------------------------------------------------------------
-- Command-line syntax
103

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

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

153
154
155
156
157
158
159
160
161
162
163
164
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

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

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

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

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
272
273
data Force = NoForce | ForceFiles | ForceAll | CannotForce
  deriving (Eq,Ord)
274

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

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

    ["dump"] -> do
369
370
371
372
        dumpPackages verbosity cli

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

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

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

387
388
389
390
readGlobPkgId :: String -> IO PackageIdentifier
readGlobPkgId str = parseCheck parseGlobPackageId str "package identifier"

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

-- globVersion means "all versions"
399
globVersion :: Version
400
401
globVersion = Version{ versionBranch=[], versionTags=["*"] }

402
403
404
405
-- -----------------------------------------------------------------------------
-- Package databases

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

414
415
416
data PackageDB 
  = PackageDB { location :: FilePath,
                packages :: [InstalledPackageInfo] }
417

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

422
allPackagesInStack :: PackageDBStack -> [InstalledPackageInfo]
423
allPackagesInStack = concatMap packages
424

425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
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
441
442
443
444
445
  -- 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
446
  global_conf <-
447
     case [ f | FlagGlobalConfig f <- my_flags ] of
Ian Lynagh's avatar
Ian Lynagh committed
448
        [] -> do mb_dir <- getLibDir
Ian Lynagh's avatar
Ian Lynagh committed
449
                 case mb_dir of
450
451
452
453
454
455
                   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
456
457
        fs -> return (last fs)

Simon Marlow's avatar
Simon Marlow committed
458
459
  let no_user_db = FlagNoUserDb `elem` my_flags

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

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

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

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

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

496
  let db_flags = [ f | Just f <- map is_db_flag my_flags ]
497
         where is_db_flag FlagUser
Ian Lynagh's avatar
Ian Lynagh committed
498
                      | Just (user_conf, _user_exists) <- mb_user_conf 
499
                      = Just user_conf
500
501
502
               is_db_flag FlagGlobal     = Just virt_global_conf
               is_db_flag (FlagConfig f) = Just f
               is_db_flag _              = Nothing
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
547
548
549
  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
550
  -- the user database (only) is allowed to be non-existent
551
552
  | Just (user_conf,False) <- mb_user_conf, path == user_conf
  = return PackageDB { location = path, packages = [] }
553
  | otherwise
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
  = 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) $
                        putStrLn ("warning: cannot read cache file " ++ cache ++ ": " ++ show ex)
                     ignore_cache
                Right tcache
                  | tcache >= tdir -> do
                     when (verbosity > Normal) $
                        putStrLn ("using cache: " ++ cache)
574
                     pkgs <- myReadBinPackageDB cache
575
576
577
578
579
580
581
582
583
584
585
586
587
588
                     let pkgs' = map convertPackageInfoIn pkgs
                     return PackageDB { location = path, packages = pkgs' }
                  | otherwise -> do
                     when (verbosity >= Normal) $ do
                        putStrLn ("WARNING: cache is out of date: " ++ cache)
                        putStrLn "  use 'ghc-pkg recache' to fix."
                     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 }

589
590
591
592
593
594
595
596
597
598
599
-- 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
600
601
602
603

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

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

618
619
620
621
622
623
624
625
626
627
628
629
-- -----------------------------------------------------------------------------
-- 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 = [] }

630
631
632
633
-- -----------------------------------------------------------------------------
-- Registering

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

644
  let
645
        db_to_operate_on = my_head "register" $
646
                           filter ((== to_modify).location) db_stack
647
  --
sof's avatar
sof committed
648
  s <-
649
    case input of
sof's avatar
sof committed
650
      "-" -> do
651
652
        when (verbosity >= Normal) $
            putStr "Reading package info from stdin ... "
653
654
655
656
#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
657
658
        getContents
      f   -> do
659
660
        when (verbosity >= Normal) $
            putStr ("Reading package info from " ++ show f ++ " ... ")
661
        readUTF8File f
662

663
  expanded <- expandEnvVars s force
664

665
  pkg <- parsePackageInfo expanded
666
667
  when (verbosity >= Normal) $
      putStrLn "done."
668

669
  let truncated_stack = dropWhile ((/= to_modify).location) db_stack
670
671
672
  -- 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
673
674
675
676
677
678
  let 
     removes = [ RemovePackage p
               | p <- packages db_to_operate_on,
                 sourcePackageId p == sourcePackageId pkg ]
  --
  changeDB verbosity (removes ++ [AddPackage pkg]) db_to_operate_on
679
680

parsePackageInfo
Ian Lynagh's avatar
Ian Lynagh committed
681
682
        :: String
        -> IO InstalledPackageInfo
683
parsePackageInfo str =
684
  case parseInstalledPackageInfo str of
685
    ParseOk _warns ok -> return ok
686
687
688
    ParseFailed err -> case locatedErrorMsg err of
                           (Nothing, s) -> die s
                           (Just l, s) -> die (show l ++ ": " ++ s)
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
726
727
728
729
730
731
732
733
734
735
736
737
-- -----------------------------------------------------------------------------
-- 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)
    writeFileAtomic file (showInstalledPackageInfo p)
  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)
738
  writeBinaryFileAtomic filename (map convertPackageInfoOut (packages db))
739
740
741
742
743
    `catch` \e ->
      if isPermissionError e
      then die (filename ++ ": you don't have permission to modify this file")
      else ioError e

744
-- -----------------------------------------------------------------------------
745
-- Exposing, Hiding, Unregistering are all similar
746

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

750
hidePackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO ()
751
hidePackage = modifyPackage (\p -> ModifyPackage p{exposed=False})
752

753
unregisterPackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO ()
754
unregisterPackage = modifyPackage RemovePackage
755
756

modifyPackage
757
  :: (InstalledPackageInfo -> DBOp)
758
  -> PackageIdentifier
759
  -> Verbosity
760
  -> [Flag]
761
  -> Force
762
  -> IO ()
763
modifyPackage fn pkgid verbosity my_flags force = do
764
765
766
767
  (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)
768
  let 
769
770
771
      db_name = location db
      pkgs    = packages db

772
      pids = map sourcePackageId ps
773

774
775
776
      cmds = [ fn pkg | pkg <- pkgs, sourcePackageId pkg `elem` pids ]
      new_db = updateInternalDB db cmds

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

788
789
790
791
792
793
794
795
796
797
798
  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
799
800
801
802

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

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

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

Ian Lynagh's avatar
Ian Lynagh committed
820
      db_stack_sorted
821
822
          = [ db{ packages = sort_pkgs (packages db) }
            | db <- db_stack_filtered ]
Ian Lynagh's avatar
Ian Lynagh committed
823
824
825
826
827
828
          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
829
                   where (p1,p2) = (sourcePackageId pkg1, sourcePackageId pkg2)
830

831
832
      stack = reverse db_stack_sorted

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

835
      pkg_map = allPackagesInStack db_stack
836
      broken = map sourcePackageId (brokenPackages pkg_map)
837

838
839
840
841
      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
842
                 pp_pkg p
843
                   | sourcePackageId p `elem` broken = printf "{%s}" doc
Ian Lynagh's avatar
Ian Lynagh committed
844
                   | exposed p = doc
845
846
                   | otherwise = printf "(%s)" doc
                   where doc | verbosity >= Verbose = printf "%s (%s)" pkg ipid
847
848
                             | otherwise            = pkg
                          where
849
850
                          InstalledPackageId ipid = installedPackageId p
                          pkg = display (sourcePackageId p)
851
852

      show_simple = simplePackageList my_flags . allPackagesInStack
853

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

858
859
  if simple_output then show_simple stack else do

860
#if defined(mingw32_HOST_OS) || __GLASGOW_HASKELL__ < 611 || defined(BOOTSTRAPPING)
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
887
888
889
  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
890
891
892
893
894

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

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

  let all_pkgs = allPackagesInStack flag_db_stack
905
      ipix  = PackageIndex.fromList all_pkgs
906
907
908
909
910

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

918
919
920
-- -----------------------------------------------------------------------------
-- Prints the highest (hidden or exposed) version of a package

921
922
923
924
925
926
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)
927
  show_pkg (sortBy compPkgIdVer (map sourcePackageId ps))
928
929
  where
    show_pkg [] = die "no matches"
930
    show_pkg pids = hPutStrLn stdout (display (last pids))
931
932
933
934

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

935
936
937
938
939
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
940
941
  doDump ps

942
943
944
945
946
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)
947
948

doDump :: [InstalledPackageInfo] -> IO ()
949
950
951
952
953
954
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
955

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

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

974
975
976
977
978
matches :: PackageIdentifier -> PackageIdentifier -> Bool
pid `matches` pid'
  = (pkgName pid == pkgName pid')
    && (pkgVersion pid == pkgVersion pid' || not (realVersion pid))

979
980
981
982
realVersion :: PackageIdentifier -> Bool
realVersion pkgid = versionBranch (pkgVersion pkgid) /= []
  -- when versionBranch == [], this is a glob

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

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

990
991
992
-- -----------------------------------------------------------------------------
-- Field

993
994
995
996
describeField :: Verbosity -> [Flag] -> PackageArg -> [String] -> IO ()
describeField verbosity my_flags pkgarg fields = do
  (_, _, flag_db_stack) <- 
      getPkgDatabases verbosity False True{-use cache-} my_flags
997
  fns <- toFields fields
998
999
  ps <- findPackages flag_db_stack pkgarg
  let top_dir = takeDirectory (location (last flag_db_stack))
1000
1001
1002
1003
1004
1005
1006
  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
1007
1008

mungePackagePaths :: String -> [InstalledPackageInfo] -> [InstalledPackageInfo]
Ian Lynagh's avatar
Ian Lynagh committed
1009
-- Replace the strings "$topdir" and "$httptopdir" at the beginning of a path
1010
1011
1012