Main.hs 90.4 KB
Newer Older
1 2
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleInstances #-}
3
{-# LANGUAGE LambdaCase #-}
4
{-# LANGUAGE MultiParamTypeClasses #-}
5 6 7 8 9 10
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ScopedTypeVariables #-}
11
{-# OPTIONS_GHC -fno-warn-orphans #-}
12 13

-- We never want to link against terminfo while bootstrapping.
Ben Gamari's avatar
Ben Gamari committed
14 15
#if defined(BOOTSTRAPPING)
#if defined(WITH_TERMINFO)
16 17 18 19
#undef WITH_TERMINFO
#endif
#endif

20
-----------------------------------------------------------------------------
21
--
22
-- (c) The University of Glasgow 2004-2009.
23
--
24
-- Package management tool
25
--
26 27
-----------------------------------------------------------------------------

28 29
module Main (main) where

Ian Lynagh's avatar
Ian Lynagh committed
30
import Version ( version, targetOS, targetARCH )
31
import qualified GHC.PackageDb as GhcPkg
32
import GHC.PackageDb (BinaryStringRep(..))
33
import qualified Distribution.Simple.PackageIndex as PackageIndex
34
import qualified Data.Graph as Graph
35 36
import qualified Distribution.ModuleName as ModuleName
import Distribution.ModuleName (ModuleName)
37
import Distribution.InstalledPackageInfo as Cabal
38
import Distribution.Compat.ReadP hiding (get)
39
import Distribution.ParseUtils
40
import Distribution.Package hiding (installedUnitId)
41
import Distribution.Text
42
import Distribution.Version
Edward Z. Yang's avatar
Edward Z. Yang committed
43
import Distribution.Backpack
44
import Distribution.Types.UnqualComponentName
45 46
import Distribution.Types.MungedPackageName
import Distribution.Types.MungedPackageId
47
import Distribution.Simple.Utils (fromUTF8BS, toUTF8BS, writeUTF8File, readUTF8File)
Edward Z. Yang's avatar
Edward Z. Yang committed
48
import qualified Data.Version as Version
49 50
import System.FilePath as FilePath
import qualified System.FilePath.Posix as FilePath.Posix
51 52 53
import System.Directory ( getAppUserDataDirectory, createDirectoryIfMissing,
                          getModificationTime )
import Text.Printf
54

55
import Prelude
56

57 58
import System.Console.GetOpt
import qualified Control.Exception as Exception
59
import Data.Maybe
Ian Lynagh's avatar
Ian Lynagh committed
60

61
import Data.Char ( isSpace, toLower )
62
import Control.Monad
63
import System.Directory ( doesDirectoryExist, getDirectoryContents,
64
                          doesFileExist, removeFile,
65
                          getCurrentDirectory )
66 67
import System.Exit ( exitWith, ExitCode(..) )
import System.Environment ( getArgs, getProgName, getEnv )
68 69 70
#if defined(darwin_HOST_OS) || defined(linux_HOST_OS)
import System.Environment ( getExecutablePath )
#endif
71
import System.IO
72
import System.IO.Error
73
import GHC.IO.Exception (IOErrorType(InappropriateType))
74
import Data.List
75
import Control.Concurrent
76 77
import qualified Data.Foldable as F
import qualified Data.Traversable as F
Edward Z. Yang's avatar
Edward Z. Yang committed
78 79
import qualified Data.Set as Set
import qualified Data.Map as Map
80

81
#if defined(mingw32_HOST_OS)
82
-- mingw32 needs these for getExecDir
83
import Foreign
Simon Marlow's avatar
Simon Marlow committed
84
import Foreign.C
85
import System.Directory ( canonicalizePath )
86 87
import GHC.ConsoleHandler
#else
88
import System.Posix hiding (fdToHandle)
rrt's avatar
rrt committed
89 90
#endif

91 92 93 94
#if defined(GLOB)
import qualified System.Info(os)
#endif

Ben Gamari's avatar
Ben Gamari committed
95
#if defined(WITH_TERMINFO)
96 97 98
import System.Console.Terminfo as Terminfo
#endif

Ben Gamari's avatar
Ben Gamari committed
99
#if defined(mingw32_HOST_OS)
100 101 102 103 104 105 106 107 108
# if defined(i386_HOST_ARCH)
#  define WINDOWS_CCONV stdcall
# elif defined(x86_64_HOST_ARCH)
#  define WINDOWS_CCONV ccall
# else
#  error Unknown mingw32 arch
# endif
#endif

thomie's avatar
thomie committed
109 110 111 112 113 114 115 116 117
-- | Short-circuit 'any' with a \"monadic predicate\".
anyM :: (Monad m) => (a -> m Bool) -> [a] -> m Bool
anyM _ [] = return False
anyM p (x:xs) = do
  b <- p x
  if b
    then return True
    else anyM p xs

118 119 120
-- -----------------------------------------------------------------------------
-- Entry point

121
main :: IO ()
122 123 124
main = do
  args <- getArgs

125
  case getOpt Permute (flags ++ deprecFlags) args of
Ian Lynagh's avatar
Ian Lynagh committed
126 127 128 129 130 131
        (cli,_,[]) | FlagHelp `elem` cli -> do
           prog <- getProgramName
           bye (usageInfo (usageHeader prog) flags)
        (cli,_,[]) | FlagVersion `elem` cli ->
           bye ourCopyright
        (cli,nonopts,[]) ->
132 133 134
           case getVerbosity Normal cli of
           Right v -> runit v cli nonopts
           Left err -> die err
135
        (_,_,errors) -> do
Ian Lynagh's avatar
Ian Lynagh committed
136
           prog <- getProgramName
137
           die (concat errors ++ shortUsage prog)
138

139 140
-- -----------------------------------------------------------------------------
-- Command-line syntax
141

142 143 144 145 146
data Flag
  = FlagUser
  | FlagGlobal
  | FlagHelp
  | FlagVersion
Ian Lynagh's avatar
Ian Lynagh committed
147
  | FlagConfig FilePath
148
  | FlagGlobalConfig FilePath
149
  | FlagUserConfig FilePath
150
  | FlagForce
151
  | FlagForceFiles
152
  | FlagMultiInstance
153
  | FlagExpandEnvVars
154 155
  | FlagExpandPkgroot
  | FlagNoExpandPkgroot
156
  | FlagSimpleOutput
157
  | FlagNamesOnly
158
  | FlagIgnoreCase
Simon Marlow's avatar
Simon Marlow committed
159
  | FlagNoUserDb
160
  | FlagVerbosity (Maybe String)
161
  | FlagUnitId
162
  deriving Eq
163

164
flags :: [OptDescr Flag]
165
flags = [
166
  Option [] ["user"] (NoArg FlagUser)
Ian Lynagh's avatar
Ian Lynagh committed
167
        "use the current user's package database",
168
  Option [] ["global"] (NoArg FlagGlobal)
169
        "use the global package database",
170 171 172 173 174 175
  Option ['f'] ["package-db"] (ReqArg FlagConfig "FILE/DIR")
        "use the specified package database",
  Option [] ["package-conf"] (ReqArg FlagConfig "FILE/DIR")
        "use the specified package database (DEPRECATED)",
  Option [] ["global-package-db"] (ReqArg FlagGlobalConfig "DIR")
        "location of the global package database",
176
  Option [] ["no-user-package-db"] (NoArg FlagNoUserDb)
Simon Marlow's avatar
Simon Marlow committed
177
        "never read the user package database",
178 179
  Option [] ["user-package-db"] (ReqArg FlagUserConfig "DIR")
        "location of the user package database (use instead of default)",
180 181
  Option [] ["no-user-package-conf"] (NoArg FlagNoUserDb)
        "never read the user package database (DEPRECATED)",
182
  Option [] ["force"] (NoArg FlagForce)
Ian Lynagh's avatar
Ian Lynagh committed
183
         "ignore missing dependencies, directories, and libraries",
184
  Option [] ["force-files"] (NoArg FlagForceFiles)
Ian Lynagh's avatar
Ian Lynagh committed
185
         "ignore missing directories and libraries only",
186 187
  Option [] ["enable-multi-instance"] (NoArg FlagMultiInstance)
        "allow registering multiple instances of the same package version",
188 189
  Option [] ["expand-env-vars"] (NoArg FlagExpandEnvVars)
        "expand environment variables (${name}-style) in input package descriptions",
190 191 192 193
  Option [] ["expand-pkgroot"] (NoArg FlagExpandPkgroot)
        "expand ${pkgroot}-relative paths to absolute in output package descriptions",
  Option [] ["no-expand-pkgroot"] (NoArg FlagNoExpandPkgroot)
        "preserve ${pkgroot}-relative paths in output package descriptions",
194
  Option ['?'] ["help"] (NoArg FlagHelp)
Ian Lynagh's avatar
Ian Lynagh committed
195
        "display this help and exit",
196
  Option ['V'] ["version"] (NoArg FlagVersion)
Ian Lynagh's avatar
Ian Lynagh committed
197
        "output version information and exit",
198
  Option [] ["simple-output"] (NoArg FlagSimpleOutput)
199 200
        "print output in easy-to-parse format for some commands",
  Option [] ["names-only"] (NoArg FlagNamesOnly)
201 202
        "only print package names, not versions; can only be used with list --simple-output",
  Option [] ["ignore-case"] (NoArg FlagIgnoreCase)
203
        "ignore case for substring matching",
204 205
  Option [] ["ipid", "unit-id"] (NoArg FlagUnitId)
        "interpret package arguments as unit IDs (e.g. installed package IDs)",
206 207
  Option ['v'] ["verbose"] (OptArg FlagVerbosity "Verbosity")
        "verbosity level (0-2, default 1)"
208
  ]
209

210 211 212 213 214 215 216 217 218 219 220 221
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

222 223
deprecFlags :: [OptDescr Flag]
deprecFlags = [
224
        -- put deprecated flags here
225
  ]
226 227

ourCopyright :: String
228
ourCopyright = "GHC package manager version " ++ Version.version ++ "\n"
229

230 231 232
shortUsage :: String -> String
shortUsage prog = "For usage information see '" ++ prog ++ " --help'."

233 234 235
usageHeader :: String -> String
usageHeader prog = substProg prog $
  "Usage:\n" ++
236 237 238
  "  $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" ++
239 240
  "    command with --package-db={path}.  To use the new database with GHC,\n" ++
  "    use GHC's -package-db flag.\n" ++
241
  "\n" ++
242
  "  $p register {filename | -}\n" ++
243 244
  "    Register the package using the specified installed package\n" ++
  "    description. The syntax for the latter is given in the $p\n" ++
245
  "    documentation.  The input file should be encoded in UTF-8.\n" ++
246
  "\n" ++
247 248
  "  $p update {filename | -}\n" ++
  "    Register the package, overwriting any other package with the\n" ++
249
  "    same name. The input file should be encoded in UTF-8.\n" ++
250
  "\n" ++
251 252
  "  $p unregister [pkg-id] \n" ++
  "    Unregister the specified packages in the order given.\n" ++
253 254 255 256 257 258 259
  "\n" ++
  "  $p expose {pkg-id}\n" ++
  "    Expose the specified package.\n" ++
  "\n" ++
  "  $p hide {pkg-id}\n" ++
  "    Hide the specified package.\n" ++
  "\n" ++
260 261 262 263 264 265
  "  $p trust {pkg-id}\n" ++
  "    Trust the specified package.\n" ++
  "\n" ++
  "  $p distrust {pkg-id}\n" ++
  "    Distrust the specified package.\n" ++
  "\n" ++
266 267 268
  "  $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
269
  "    all the registered versions will be listed in ascending order.\n" ++
270 271
  "    Accepts the --simple-output flag.\n" ++
  "\n" ++
272 273
  "  $p dot\n" ++
  "    Generate a graph of the package dependencies in a form suitable\n" ++
274 275
  "    for input for the graphviz tools.  For example, to generate a PDF\n" ++
  "    of the dependency graph: ghc-pkg dot | tred | dot -Tpdf >pkgs.pdf\n" ++
276
  "\n" ++
277 278
  "  $p find-module {module}\n" ++
  "    List registered packages exposing module {module} in the global\n" ++
Ian Lynagh's avatar
Ian Lynagh committed
279
  "    database, and also the user database if --user is given.\n" ++
280
  "    All the registered versions will be listed in ascending order.\n" ++
281
  "    Accepts the --simple-output flag.\n" ++
282
  "\n" ++
283
  "  $p latest {pkg-id}\n" ++
284
  "    Prints the highest registered version of a package.\n" ++
285
  "\n" ++
286
  "  $p check\n" ++
287
  "    Check the consistency of package dependencies and list broken packages.\n" ++
288 289
  "    Accepts the --simple-output flag.\n" ++
  "\n" ++
290
  "  $p describe {pkg}\n" ++
291 292 293 294
  "    Give the registered description for the specified package. The\n" ++
  "    description is returned in precisely the syntax required by $p\n" ++
  "    register.\n" ++
  "\n" ++
295
  "  $p field {pkg} {field}\n" ++
296
  "    Extract the specified field of the package description for the\n" ++
297 298
  "    specified package. Accepts comma-separated multiple fields.\n" ++
  "\n" ++
299 300 301
  "  $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" ++
302 303
  "    by tools that parse the results, rather than humans.  The output is\n" ++
  "    always encoded in UTF-8, regardless of the current locale.\n" ++
304
  "\n" ++
305 306 307 308
  "  $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" ++
309
  "    is recached; to recache a different DB use --user or --package-db\n" ++
310 311
  "    as appropriate.\n" ++
  "\n" ++
312 313
  " Substring matching is supported for {module} in find-module and\n" ++
  " for {pkg} in list, describe, and field, where a '*' indicates\n" ++
314 315
  " open substring ends (prefix*, *suffix, *infix*).  Use --ipid to\n" ++
  " match against the installed package ID instead.\n" ++
316
  "\n" ++
317 318 319
  "  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"++
320
  "  or --package-db can be used to act on another database\n"++
321 322 323
  "  entirely. When multiple of these options are given, the rightmost\n"++
  "  one is used as the database to act upon.\n"++
  "\n"++
324
  "  Commands that query the package database (list, tree, latest, describe,\n"++
325
  "  field) operate on the list of databases specified by the flags\n"++
326
  "  --user, --global, and --package-db.  If none of these flags are\n"++
327 328
  "  given, the default is --global --user.\n"++
  "\n" ++
329
  " The following optional flags are also accepted:\n"
330 331 332 333 334 335 336 337 338

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
339 340
data Force = NoForce | ForceFiles | ForceAll | CannotForce
  deriving (Eq,Ord)
341

342 343
-- | Enum flag representing argument type
data AsPackageArg
344
    = AsUnitId
345 346
    | AsDefault

347 348
-- | Represents how a package may be specified by a user on the command line.
data PackageArg
349 350
    -- | A package identifier foo-0.1, or a glob foo-*
    = Id GlobPackageIdentifier
351 352
    -- | An installed package ID foo-0.1-HASH.  This is guaranteed to uniquely
    -- match a single entry in the package database.
353
    | IUId UnitId
354
    -- | A glob against the package name.  The first string is the literal
thomie's avatar
thomie committed
355
    -- glob, the second is a function which returns @True@ if the argument
356 357
    -- matches.
    | Substring String (String->Bool)
358

359 360
runit :: Verbosity -> [Flag] -> [String] -> IO ()
runit verbosity cli nonopts = do
361
  installSignalHandlers -- catch ^C and clean up
362 363
  when (verbosity >= Verbose)
    (putStr ourCopyright)
364 365
  prog <- getProgramName
  let
Ian Lynagh's avatar
Ian Lynagh committed
366 367
        force
          | FlagForce `elem` cli        = ForceAll
368 369
          | FlagForceFiles `elem` cli   = ForceFiles
          | otherwise                   = NoForce
370 371
        as_arg | FlagUnitId `elem` cli = AsUnitId
               | otherwise             = AsDefault
372
        multi_instance = FlagMultiInstance `elem` cli
373
        expand_env_vars= FlagExpandEnvVars `elem` cli
374 375 376 377
        mexpand_pkgroot= foldl' accumExpandPkgroot Nothing cli
          where accumExpandPkgroot _ FlagExpandPkgroot   = Just True
                accumExpandPkgroot _ FlagNoExpandPkgroot = Just False
                accumExpandPkgroot x _                   = x
378

379 380 381 382
        splitFields fields = unfoldr splitComma (',':fields)
          where splitComma "" = Nothing
                splitComma fs = Just $ break (==',') (tail fs)

383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404
        -- | Parses a glob into a predicate which tests if a string matches
        -- the glob.  Returns Nothing if the string in question is not a glob.
        -- At the moment, we only support globs at the beginning and/or end of
        -- strings.  This function respects case sensitivity.
        --
        -- >>> fromJust (substringCheck "*") "anything"
        -- True
        --
        -- >>> fromJust (substringCheck "string") "string"
        -- True
        --
        -- >>> fromJust (substringCheck "*bar") "foobar"
        -- True
        --
        -- >>> fromJust (substringCheck "foo*") "foobar"
        -- True
        --
        -- >>> fromJust (substringCheck "*ooba*") "foobar"
        -- True
        --
        -- >>> fromJust (substringCheck "f*bar") "foobar"
        -- False
405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424
        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
425 426 427
  --
  -- first, parse the command
  case nonopts of
428 429 430 431 432 433 434 435 436
#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
437 438
    ["init", filename] ->
        initPackageDB filename verbosity cli
Ian Lynagh's avatar
Ian Lynagh committed
439
    ["register", filename] ->
440
        registerPackage filename verbosity cli
thomie's avatar
thomie committed
441
                        multi_instance
442
                        expand_env_vars False force
Ian Lynagh's avatar
Ian Lynagh committed
443
    ["update", filename] ->
444
        registerPackage filename verbosity cli
thomie's avatar
thomie committed
445
                        multi_instance
446
                        expand_env_vars True force
447 448 449 450
    "unregister" : pkgarg_strs@(_:_) -> do
        forM_ pkgarg_strs $ \pkgarg_str -> do
          pkgarg <- readPackageArg as_arg pkgarg_str
          unregisterPackage pkgarg verbosity cli force
451
    ["expose", pkgarg_str] -> do
452
        pkgarg <- readPackageArg as_arg pkgarg_str
453 454
        exposePackage pkgarg verbosity cli force
    ["hide",   pkgarg_str] -> do
455
        pkgarg <- readPackageArg as_arg pkgarg_str
456 457
        hidePackage pkgarg verbosity cli force
    ["trust",    pkgarg_str] -> do
458
        pkgarg <- readPackageArg as_arg pkgarg_str
459 460
        trustPackage pkgarg verbosity cli force
    ["distrust", pkgarg_str] -> do
461
        pkgarg <- readPackageArg as_arg pkgarg_str
462
        distrustPackage pkgarg verbosity cli force
463
    ["list"] -> do
464
        listPackages verbosity cli Nothing Nothing
465 466
    ["list", pkgarg_str] ->
        case substringCheck pkgarg_str of
467
          Nothing -> do pkgarg <- readPackageArg as_arg pkgarg_str
468 469 470
                        listPackages verbosity cli (Just pkgarg) Nothing
          Just m -> listPackages verbosity cli
                                 (Just (Substring pkgarg_str m)) Nothing
471 472
    ["dot"] -> do
        showPackageDot verbosity cli
Edward Z. Yang's avatar
Edward Z. Yang committed
473 474
    ["find-module", mod_name] -> do
        let match = maybe (==mod_name) id (substringCheck mod_name)
475
        listPackages verbosity cli Nothing (Just match)
476
    ["latest", pkgid_str] -> do
Ian Lynagh's avatar
Ian Lynagh committed
477
        pkgid <- readGlobPkgId pkgid_str
478
        latestPackage verbosity cli pkgid
479 480
    ["describe", pkgid_str] -> do
        pkgarg <- case substringCheck pkgid_str of
481
          Nothing -> readPackageArg as_arg pkgid_str
482 483
          Just m  -> return (Substring pkgid_str m)
        describePackage verbosity cli pkgarg (fromMaybe False mexpand_pkgroot)
484

485 486
    ["field", pkgid_str, fields] -> do
        pkgarg <- case substringCheck pkgid_str of
487
          Nothing -> readPackageArg as_arg pkgid_str
488 489 490 491
          Just m  -> return (Substring pkgid_str m)
        describeField verbosity cli pkgarg
                      (splitFields fields) (fromMaybe True mexpand_pkgroot)

492
    ["check"] -> do
493
        checkConsistency verbosity cli
494 495

    ["dump"] -> do
496
        dumpPackages verbosity cli (fromMaybe False mexpand_pkgroot)
497 498 499

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

501
    [] -> do
502
        die ("missing command\n" ++ shortUsage prog)
503
    (_cmd:_) -> do
504
        die ("command-line syntax error\n" ++ shortUsage prog)
505 506

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

512 513 514
-- | Either an exact 'PackageIdentifier', or a glob for all packages
-- matching 'PackageName'.
data GlobPackageIdentifier
515 516
    = ExactPackageIdentifier MungedPackageId
    | GlobPackageIdentifier  MungedPackageName
517 518 519 520 521 522

displayGlobPkgId :: GlobPackageIdentifier -> String
displayGlobPkgId (ExactPackageIdentifier pid) = display pid
displayGlobPkgId (GlobPackageIdentifier pn) = display pn ++ "-*"

readGlobPkgId :: String -> IO GlobPackageIdentifier
523 524
readGlobPkgId str = parseCheck parseGlobPackageId str "package identifier"

525
parseGlobPackageId :: ReadP r GlobPackageIdentifier
Ian Lynagh's avatar
Ian Lynagh committed
526
parseGlobPackageId =
527
  fmap ExactPackageIdentifier parse
528
     +++
Ian Lynagh's avatar
Ian Lynagh committed
529
  (do n <- parse
530
      _ <- string "-*"
531
      return (GlobPackageIdentifier n))
532

533
readPackageArg :: AsPackageArg -> String -> IO PackageArg
534 535
readPackageArg AsUnitId str =
    parseCheck (IUId `fmap` parse) str "installed package id"
536
readPackageArg AsDefault str = Id `fmap` readGlobPkgId str
537

538 539 540 541
-- -----------------------------------------------------------------------------
-- Package databases

-- Some commands operate on a single database:
542
--      register, unregister, expose, hide, trust, distrust
543 544 545 546 547
-- 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
548
--      list, describe, field
549

550
data PackageDB (mode :: GhcPkg.DbMode)
551 552
  = PackageDB {
      location, locationAbsolute :: !FilePath,
553
      -- We need both possibly-relative and definitely-absolute package
554 555 556 557
      -- db locations. This is because the relative location is used as
      -- an identifier for the db, so it is important we do not modify it.
      -- On the other hand we need the absolute path in a few places
      -- particularly in relation to the ${pkgroot} stuff.
558

559 560 561 562
      packageDbLock :: !(GhcPkg.DbOpenMode mode GhcPkg.PackageDbLock),
      -- If package db is open in read write mode, we keep its lock around for
      -- transactional updates.

563 564
      packages :: [InstalledPackageInfo]
    }
565

566
type PackageDBStack = [PackageDB 'GhcPkg.DbReadOnly]
Ian Lynagh's avatar
Ian Lynagh committed
567
        -- A stack of package databases.  Convention: head is the topmost
568
        -- in the stack.
569

570 571 572 573 574
-- | Selector for picking the right package DB to modify as 'register' and
-- 'recache' operate on the database on top of the stack, whereas 'modify'
-- changes the first database that contains a specific package.
data DbModifySelector = TopOne | ContainsPkg PackageArg

575
allPackagesInStack :: PackageDBStack -> [InstalledPackageInfo]
576
allPackagesInStack = concatMap packages
577

578
getPkgDatabases :: Verbosity
579
                -> GhcPkg.DbOpenMode mode DbModifySelector
580
                -> Bool    -- use the user db
581
                -> Bool    -- read caches, if available
582
                -> Bool    -- expand vars, like ${pkgroot} and $topdir
583
                -> [Flag]
584 585
                -> IO (PackageDBStack,
                          -- the real package DB stack: [global,user] ++
586
                          -- DBs specified on the command line with -f.
587
                       GhcPkg.DbOpenMode mode (PackageDB mode),
588 589 590 591 592 593 594
                          -- 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'.

595
getPkgDatabases verbosity mode use_user use_cache expand_vars my_flags = do
596 597
  -- 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
598
  -- location is passed to the binary using the --global-package-db flag by the
599
  -- wrapper script.
600
  let err_msg = "missing --global-package-db option, location of global package database unknown\n"
Ian Lynagh's avatar
Ian Lynagh committed
601
  global_conf <-
602
     case [ f | FlagGlobalConfig f <- my_flags ] of
Ian Lynagh's avatar
Ian Lynagh committed
603
        [] -> do mb_dir <- getLibDir
Ian Lynagh's avatar
Ian Lynagh committed
604
                 case mb_dir of
605 606 607 608 609 610
                   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
611 612
        fs -> return (last fs)

613 614 615 616 617 618
  -- The value of the $topdir variable used in some package descriptions
  -- Note that the way we calculate this is slightly different to how it
  -- is done in ghc itself. We rely on the convention that the global
  -- package db lives in ghc's libdir.
  top_dir <- absolutePath (takeDirectory global_conf)

Simon Marlow's avatar
Simon Marlow committed
619 620
  let no_user_db = FlagNoUserDb `elem` my_flags

621
  -- get the location of the user package database, and create it if necessary
622
  -- getAppUserDataDirectory can fail (e.g. if $HOME isn't set)
623
  e_appdir <- tryIO $ getAppUserDataDirectory "ghc"
624 625

  mb_user_conf <-
626 627 628 629 630 631 632 633 634 635 636 637
    case [ f | FlagUserConfig f <- my_flags ] of
      _ | no_user_db -> return Nothing
      [] -> 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))
      fs -> return (Just (last fs, True))
638

639 640 641
  -- If the user database exists, and for "use_user" commands (which includes
  -- "ghc-pkg check" and all commands that modify the db) we will attempt to
  -- use the user db.
642
  let sys_databases
643
        | Just (user_conf,user_exists) <- mb_user_conf,
644 645
          use_user || user_exists = [user_conf, global_conf]
        | otherwise               = [global_conf]
646

647
  e_pkg_path <- tryIO (System.Environment.getEnv "GHC_PACKAGE_PATH")
648
  let env_stack =
Ian Lynagh's avatar
Ian Lynagh committed
649 650 651
        case e_pkg_path of
                Left  _ -> sys_databases
                Right path
652 653 654 655
                  | not (null path) && isSearchPathSeparator (last path)
                  -> splitSearchPath (init path) ++ sys_databases
                  | otherwise
                  -> splitSearchPath path
Ian Lynagh's avatar
Ian Lynagh committed
656 657 658

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

661
  let db_flags = [ f | Just f <- map is_db_flag my_flags ]
662
         where is_db_flag FlagUser
663
                      | Just (user_conf, _user_exists) <- mb_user_conf
664
                      = Just user_conf
665 666 667
               is_db_flag FlagGlobal     = Just virt_global_conf
               is_db_flag (FlagConfig f) = Just f
               is_db_flag _              = Nothing
668

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

684 685 686
      top_db = if null db_flags
               then virt_global_conf
               else last db_flags
687

688 689
  (db_stack, db_to_operate_on) <- getDatabases top_dir mb_user_conf
                                               flag_db_names final_stack top_db
690 691 692 693

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

694 695
  when (verbosity > Normal) $ do
    infoLn ("db stack: " ++ show (map location db_stack))
696 697
    F.forM_ db_to_operate_on $ \db ->
      infoLn ("modifying: " ++ (location db))
698 699
    infoLn ("flag db stack: " ++ show (map location flag_db_stack))

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 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794
  return (db_stack, db_to_operate_on, flag_db_stack)
  where
    getDatabases top_dir mb_user_conf flag_db_names
                 final_stack top_db = case mode of
      -- When we open in read only mode, we simply read all of the databases/
      GhcPkg.DbOpenReadOnly -> do
        db_stack <- mapM readDatabase final_stack
        return (db_stack, GhcPkg.DbOpenReadOnly)

      -- The only package db we open in read write mode is the one on the top of
      -- the stack.
      GhcPkg.DbOpenReadWrite TopOne -> do
        (db_stack, mto_modify) <- stateSequence Nothing
          [ \case
              to_modify@(Just _) -> (, to_modify) <$> readDatabase db_path
              Nothing -> if db_path /= top_db
                then (, Nothing) <$> readDatabase db_path
                else do
                  db <- readParseDatabase verbosity mb_user_conf
                                          mode use_cache db_path
                    `Exception.catch` couldntOpenDbForModification db_path
                  let ro_db = db { packageDbLock = GhcPkg.DbOpenReadOnly }
                  return (ro_db, Just db)
          | db_path <- final_stack ]

        to_modify <- case mto_modify of
          Just db -> return db
          Nothing -> die "no database selected for modification"

        return (db_stack, GhcPkg.DbOpenReadWrite to_modify)

      -- The package db we open in read write mode is the first one included in
      -- flag_db_names that contains specified package. Therefore we need to
      -- open each one in read/write mode first and decide whether it's for
      -- modification based on its contents.
      GhcPkg.DbOpenReadWrite (ContainsPkg pkgarg) -> do
        (db_stack, mto_modify) <- stateSequence Nothing
          [ \case
              to_modify@(Just _) -> (, to_modify) <$> readDatabase db_path
              Nothing -> if db_path `notElem` flag_db_names
                then (, Nothing) <$> readDatabase db_path
                else do
                  let hasPkg :: PackageDB mode -> Bool
                      hasPkg = not . null . findPackage pkgarg . packages

                      openRo (e::IOError) = do
                        db <- readDatabase db_path
                        if hasPkg db
                          then couldntOpenDbForModification db_path e
                          else return (db, Nothing)

                  -- If we fail to open the database in read/write mode, we need
                  -- to check if it's for modification first before throwing an
                  -- error, so we attempt to open it in read only mode.
                  Exception.handle openRo $ do
                    db <- readParseDatabase verbosity mb_user_conf
                                            mode use_cache db_path
                    let ro_db = db { packageDbLock = GhcPkg.DbOpenReadOnly }
                    if hasPkg db
                      then return (ro_db, Just db)
                      else do
                        -- If the database is not for modification after all,
                        -- drop the write lock as we are already finished with
                        -- the database.
                        case packageDbLock db of
                          GhcPkg.DbOpenReadWrite lock ->
                            GhcPkg.unlockPackageDb lock
                        return (ro_db, Nothing)
          | db_path <- final_stack ]

        to_modify <- case mto_modify of
          Just db -> return db
          Nothing -> cannotFindPackage pkgarg Nothing

        return (db_stack, GhcPkg.DbOpenReadWrite to_modify)
      where
        couldntOpenDbForModification :: FilePath -> IOError -> IO a
        couldntOpenDbForModification db_path e = die $ "Couldn't open database "
          ++ db_path ++ " for modification: " ++ show e

        -- Parse package db in read-only mode.
        readDatabase :: FilePath -> IO (PackageDB 'GhcPkg.DbReadOnly)
        readDatabase db_path = do
          db <- readParseDatabase verbosity mb_user_conf
                                  GhcPkg.DbOpenReadOnly use_cache db_path
          if expand_vars
            then return $ mungePackageDBPaths top_dir db
            else return db

    stateSequence :: Monad m => s -> [s -> m (a, s)] -> m ([a], s)
    stateSequence s []     = return ([], s)
    stateSequence s (m:ms) = do
      (a, s')   <- m s
      (as, s'') <- stateSequence s' ms
      return (a : as, s'')
795 796 797 798 799 800

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
801 802 803
    let path_file = dir </> "package.conf"
    exists_file <- doesFileExist path_file
    if exists_file then return (Just path_file) else return Nothing
804

805
readParseDatabase :: forall mode t. Verbosity
806
                  -> Maybe (FilePath,Bool)
807
                  -> GhcPkg.DbOpenMode mode t
808 809
                  -> Bool -- use cache
                  -> FilePath
810 811
                  -> IO (PackageDB mode)
readParseDatabase verbosity mb_user_conf mode use_cache path
812
  -- the user database (only) is allowed to be non-existent
813
  | Just (user_conf,False) <- mb_user_conf, path == user_conf
814 815 816 817
  = do lock <- F.forM mode $ \_ -> do
         createDirectoryIfMissing True path
         GhcPkg.lockPackageDb cache
       mkPackageDB [] lock
818
  | otherwise
819
  = do e <- tryIO $ getDirectoryContents path
820
       case e of
821
         Left err
822 823 824 825
           | ioeGetErrorType err == InappropriateType -> do
              -- We provide a limited degree of backwards compatibility for
              -- old single-file style db:
              mdb <- tryReadParseOldFileStyleDatabase verbosity
826
                       mb_user_conf mode use_cache path
827 828 829 830 831 832 833
              case mdb of
                Just db -> return db
                Nothing ->
                  die $ "ghc no longer supports single-file style package "
                     ++ "databases (" ++ path ++ ") use 'ghc-pkg init'"
                     ++ "to create the database with the correct format."

834
           | otherwise -> ioError err
835
         Right fs
836
           | not use_cache -> ignore_cache (const $ return ())
837
           | otherwise -> do
838
              e_tcache <- tryIO $ getModificationTime cache
839 840
              case e_tcache of
                Left ex -> do
841
                  whenReportCacheErrors $