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 GHC.HandleEncoding
34
import qualified Distribution.Simple.PackageIndex as PackageIndex
35
import qualified Data.Graph as Graph
36 37
import qualified Distribution.ModuleName as ModuleName
import Distribution.ModuleName (ModuleName)
38
import Distribution.InstalledPackageInfo as Cabal
39
import Distribution.Compat.ReadP hiding (get)
40
import Distribution.ParseUtils
41
import Distribution.Package hiding (installedUnitId)
42
import Distribution.Text
43
import Distribution.Version
Edward Z. Yang's avatar
Edward Z. Yang committed
44
import Distribution.Backpack
45
import Distribution.Types.UnqualComponentName
46 47
import Distribution.Types.MungedPackageName
import Distribution.Types.MungedPackageId
48
import Distribution.Simple.Utils (fromUTF8BS, toUTF8BS, writeUTF8File, readUTF8File)
Edward Z. Yang's avatar
Edward Z. Yang committed
49
import qualified Data.Version as Version
50 51
import System.FilePath as FilePath
import qualified System.FilePath.Posix as FilePath.Posix
52 53 54
import System.Directory ( getAppUserDataDirectory, createDirectoryIfMissing,
                          getModificationTime )
import Text.Printf
55

56
import Prelude
57

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

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

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

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

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

Ben Gamari's avatar
Ben Gamari committed
100
#if defined(mingw32_HOST_OS)
101 102 103 104 105 106 107 108 109
# 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
110 111 112 113 114 115 116 117 118
-- | 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

119 120 121
-- -----------------------------------------------------------------------------
-- Entry point

122
main :: IO ()
123
main = do
124
  configureHandleEncoding
125 126
  args <- getArgs

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

141 142
-- -----------------------------------------------------------------------------
-- Command-line syntax
143

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

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

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

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

ourCopyright :: String
230
ourCopyright = "GHC package manager version " ++ Version.version ++ "\n"
231

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

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

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

344 345
-- | Enum flag representing argument type
data AsPackageArg
346
    = AsUnitId
347 348
    | AsDefault

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

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

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

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

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

494
    ["check"] -> do
495
        checkConsistency verbosity cli
496 497

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

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

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

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

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

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

readGlobPkgId :: String -> IO GlobPackageIdentifier
525 526
readGlobPkgId str = parseCheck parseGlobPackageId str "package identifier"

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

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

540 541 542 543
-- -----------------------------------------------------------------------------
-- Package databases

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

552
data PackageDB (mode :: GhcPkg.DbMode)
553 554
  = PackageDB {
      location, locationAbsolute :: !FilePath,
555
      -- We need both possibly-relative and definitely-absolute package
556 557 558 559
      -- 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.
560

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

565 566
      packages :: [InstalledPackageInfo]
    }
567

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

572 573 574 575 576
-- | 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

577
allPackagesInStack :: PackageDBStack -> [InstalledPackageInfo]
578
allPackagesInStack = concatMap packages
579

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

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

615 616 617 618 619 620
  -- 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
621 622
  let no_user_db = FlagNoUserDb `elem` my_flags

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

  mb_user_conf <-
628 629 630 631 632 633 634 635 636 637 638 639
    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))
640

641 642 643
  -- 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.
644
  let sys_databases
645
        | Just (user_conf,user_exists) <- mb_user_conf,
646 647
          use_user || user_exists = [user_conf, global_conf]
        | otherwise               = [global_conf]
648

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

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

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

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

686 687 688
      top_db = if null db_flags
               then virt_global_conf
               else last db_flags
689

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

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

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

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 795 796
  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'')
797 798 799 800 801 802

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

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

836
           | otherwise -> ioError err
837
         Right fs
838
           | not use_cache -> ignore_cache (const $ return ())
839
           | otherwise -> do
840
              e_tcache <- tryIO $ getModificationTime cache
841 842
              case e_tcache of
                Left ex -> do
843
                  whenReportCacheErrors $
844
                    if isDoesNotExistError ex
845
                      then
846 847 848
                        -- It's fine if the cache is not there as long as the
                        -- database is empty.
                        when (not $ null confs) $ do
849 850 851
                            warn ("WARNING: cache does not exist: " ++ cache)
                            warn ("ghc will fail to read this package db. " ++
                                  recacheAdvice)
852 853 854 855
                      else do
                        warn ("WARNING: cache cannot be read: " ++ show ex)
                        warn "ghc will fail to read this package db."
                  ignore_cache (const $ return ())
856 857 858
                Right tcache -> do
                  when (verbosity >= Verbose) $ do
                      warn ("Timestamp " ++ show tcache ++ " for " ++ cache)
859 860 861 862 863
                  -- If any of the .conf files is newer than package.cache, we
                  -- assume that cache is out of date.
                  cache_outdated <- (`anyM` confs) $ \conf ->
                    (tcache <) <$> getModificationTime conf
                  if not cache_outdated
864 865 866
                      then do
                          when (verbosity > Normal) $
                             infoLn ("using cache: " ++ cache)
867 868
                          GhcPkg.readPackageDbForGhcPkg cache mode
                            >>= uncurry mkPackageDB
ian@well-typed.com's avatar