c5ecbf23e14b8ddcbcd0dde2612c238a82913dde
[ghc.git] / utils / ghc-pkg / Main.hs
1 {-# LANGUAGE CPP #-}
2 {-# LANGUAGE FlexibleInstances #-}
3 {-# LANGUAGE LambdaCase #-}
4 {-# LANGUAGE MultiParamTypeClasses #-}
5 {-# LANGUAGE TypeSynonymInstances #-}
6 {-# LANGUAGE GADTs #-}
7 {-# LANGUAGE KindSignatures #-}
8 {-# LANGUAGE DataKinds #-}
9 {-# LANGUAGE TupleSections #-}
10 {-# LANGUAGE ScopedTypeVariables #-}
11 {-# OPTIONS_GHC -fno-warn-orphans #-}
12
13 -- We never want to link against terminfo while bootstrapping.
14 #ifdef BOOTSTRAPPING
15 #ifdef WITH_TERMINFO
16 #undef WITH_TERMINFO
17 #endif
18 #endif
19
20 -----------------------------------------------------------------------------
21 --
22 -- (c) The University of Glasgow 2004-2009.
23 --
24 -- Package management tool
25 --
26 -----------------------------------------------------------------------------
27
28 module Main (main) where
29
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 import qualified Distribution.ModuleName as ModuleName
36 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
43 import Distribution.Backpack
44 import Distribution.Types.UnqualComponentName
45 import Distribution.Simple.Utils (fromUTF8, toUTF8, writeUTF8File, readUTF8File)
46 import qualified Data.Version as Version
47 import System.FilePath as FilePath
48 import qualified System.FilePath.Posix as FilePath.Posix
49 import System.Directory ( getAppUserDataDirectory, createDirectoryIfMissing,
50 getModificationTime )
51 import Text.Printf
52
53 import Prelude
54
55 import System.Console.GetOpt
56 import qualified Control.Exception as Exception
57 import Data.Maybe
58
59 import Data.Char ( isSpace, toLower )
60 import Control.Monad
61 import System.Directory ( doesDirectoryExist, getDirectoryContents,
62 doesFileExist, removeFile,
63 getCurrentDirectory )
64 import System.Exit ( exitWith, ExitCode(..) )
65 import System.Environment ( getArgs, getProgName, getEnv )
66 import System.IO
67 import System.IO.Error
68 import GHC.IO.Exception (IOErrorType(InappropriateType))
69 import Data.List
70 import Control.Concurrent
71 import qualified Data.Foldable as F
72 import qualified Data.Traversable as F
73 import qualified Data.Set as Set
74 import qualified Data.Map as Map
75
76 import qualified Data.ByteString.Char8 as BS
77
78 #if defined(mingw32_HOST_OS)
79 -- mingw32 needs these for getExecDir
80 import Foreign
81 import Foreign.C
82 import System.Directory ( canonicalizePath )
83 import GHC.ConsoleHandler
84 #else
85 import System.Posix hiding (fdToHandle)
86 #endif
87
88 #if defined(GLOB)
89 import qualified System.Info(os)
90 #endif
91
92 #ifdef WITH_TERMINFO
93 import System.Console.Terminfo as Terminfo
94 #endif
95
96 #ifdef mingw32_HOST_OS
97 # if defined(i386_HOST_ARCH)
98 # define WINDOWS_CCONV stdcall
99 # elif defined(x86_64_HOST_ARCH)
100 # define WINDOWS_CCONV ccall
101 # else
102 # error Unknown mingw32 arch
103 # endif
104 #endif
105
106 -- | Short-circuit 'any' with a \"monadic predicate\".
107 anyM :: (Monad m) => (a -> m Bool) -> [a] -> m Bool
108 anyM _ [] = return False
109 anyM p (x:xs) = do
110 b <- p x
111 if b
112 then return True
113 else anyM p xs
114
115 -- -----------------------------------------------------------------------------
116 -- Entry point
117
118 main :: IO ()
119 main = do
120 args <- getArgs
121
122 case getOpt Permute (flags ++ deprecFlags) args of
123 (cli,_,[]) | FlagHelp `elem` cli -> do
124 prog <- getProgramName
125 bye (usageInfo (usageHeader prog) flags)
126 (cli,_,[]) | FlagVersion `elem` cli ->
127 bye ourCopyright
128 (cli,nonopts,[]) ->
129 case getVerbosity Normal cli of
130 Right v -> runit v cli nonopts
131 Left err -> die err
132 (_,_,errors) -> do
133 prog <- getProgramName
134 die (concat errors ++ shortUsage prog)
135
136 -- -----------------------------------------------------------------------------
137 -- Command-line syntax
138
139 data Flag
140 = FlagUser
141 | FlagGlobal
142 | FlagHelp
143 | FlagVersion
144 | FlagConfig FilePath
145 | FlagGlobalConfig FilePath
146 | FlagUserConfig FilePath
147 | FlagForce
148 | FlagForceFiles
149 | FlagMultiInstance
150 | FlagExpandEnvVars
151 | FlagExpandPkgroot
152 | FlagNoExpandPkgroot
153 | FlagSimpleOutput
154 | FlagNamesOnly
155 | FlagIgnoreCase
156 | FlagNoUserDb
157 | FlagVerbosity (Maybe String)
158 | FlagUnitId
159 deriving Eq
160
161 flags :: [OptDescr Flag]
162 flags = [
163 Option [] ["user"] (NoArg FlagUser)
164 "use the current user's package database",
165 Option [] ["global"] (NoArg FlagGlobal)
166 "use the global package database",
167 Option ['f'] ["package-db"] (ReqArg FlagConfig "FILE/DIR")
168 "use the specified package database",
169 Option [] ["package-conf"] (ReqArg FlagConfig "FILE/DIR")
170 "use the specified package database (DEPRECATED)",
171 Option [] ["global-package-db"] (ReqArg FlagGlobalConfig "DIR")
172 "location of the global package database",
173 Option [] ["no-user-package-db"] (NoArg FlagNoUserDb)
174 "never read the user package database",
175 Option [] ["user-package-db"] (ReqArg FlagUserConfig "DIR")
176 "location of the user package database (use instead of default)",
177 Option [] ["no-user-package-conf"] (NoArg FlagNoUserDb)
178 "never read the user package database (DEPRECATED)",
179 Option [] ["force"] (NoArg FlagForce)
180 "ignore missing dependencies, directories, and libraries",
181 Option [] ["force-files"] (NoArg FlagForceFiles)
182 "ignore missing directories and libraries only",
183 Option [] ["enable-multi-instance"] (NoArg FlagMultiInstance)
184 "allow registering multiple instances of the same package version",
185 Option [] ["expand-env-vars"] (NoArg FlagExpandEnvVars)
186 "expand environment variables (${name}-style) in input package descriptions",
187 Option [] ["expand-pkgroot"] (NoArg FlagExpandPkgroot)
188 "expand ${pkgroot}-relative paths to absolute in output package descriptions",
189 Option [] ["no-expand-pkgroot"] (NoArg FlagNoExpandPkgroot)
190 "preserve ${pkgroot}-relative paths in output package descriptions",
191 Option ['?'] ["help"] (NoArg FlagHelp)
192 "display this help and exit",
193 Option ['V'] ["version"] (NoArg FlagVersion)
194 "output version information and exit",
195 Option [] ["simple-output"] (NoArg FlagSimpleOutput)
196 "print output in easy-to-parse format for some commands",
197 Option [] ["names-only"] (NoArg FlagNamesOnly)
198 "only print package names, not versions; can only be used with list --simple-output",
199 Option [] ["ignore-case"] (NoArg FlagIgnoreCase)
200 "ignore case for substring matching",
201 Option [] ["ipid", "unit-id"] (NoArg FlagUnitId)
202 "interpret package arguments as unit IDs (e.g. installed package IDs)",
203 Option ['v'] ["verbose"] (OptArg FlagVerbosity "Verbosity")
204 "verbosity level (0-2, default 1)"
205 ]
206
207 data Verbosity = Silent | Normal | Verbose
208 deriving (Show, Eq, Ord)
209
210 getVerbosity :: Verbosity -> [Flag] -> Either String Verbosity
211 getVerbosity v [] = Right v
212 getVerbosity _ (FlagVerbosity Nothing : fs) = getVerbosity Verbose fs
213 getVerbosity _ (FlagVerbosity (Just "0") : fs) = getVerbosity Silent fs
214 getVerbosity _ (FlagVerbosity (Just "1") : fs) = getVerbosity Normal fs
215 getVerbosity _ (FlagVerbosity (Just "2") : fs) = getVerbosity Verbose fs
216 getVerbosity _ (FlagVerbosity v : _) = Left ("Bad verbosity: " ++ show v)
217 getVerbosity v (_ : fs) = getVerbosity v fs
218
219 deprecFlags :: [OptDescr Flag]
220 deprecFlags = [
221 -- put deprecated flags here
222 ]
223
224 ourCopyright :: String
225 ourCopyright = "GHC package manager version " ++ Version.version ++ "\n"
226
227 shortUsage :: String -> String
228 shortUsage prog = "For usage information see '" ++ prog ++ " --help'."
229
230 usageHeader :: String -> String
231 usageHeader prog = substProg prog $
232 "Usage:\n" ++
233 " $p init {path}\n" ++
234 " Create and initialise a package database at the location {path}.\n" ++
235 " Packages can be registered in the new database using the register\n" ++
236 " command with --package-db={path}. To use the new database with GHC,\n" ++
237 " use GHC's -package-db flag.\n" ++
238 "\n" ++
239 " $p register {filename | -}\n" ++
240 " Register the package using the specified installed package\n" ++
241 " description. The syntax for the latter is given in the $p\n" ++
242 " documentation. The input file should be encoded in UTF-8.\n" ++
243 "\n" ++
244 " $p update {filename | -}\n" ++
245 " Register the package, overwriting any other package with the\n" ++
246 " same name. The input file should be encoded in UTF-8.\n" ++
247 "\n" ++
248 " $p unregister [pkg-id] \n" ++
249 " Unregister the specified packages in the order given.\n" ++
250 "\n" ++
251 " $p expose {pkg-id}\n" ++
252 " Expose the specified package.\n" ++
253 "\n" ++
254 " $p hide {pkg-id}\n" ++
255 " Hide the specified package.\n" ++
256 "\n" ++
257 " $p trust {pkg-id}\n" ++
258 " Trust the specified package.\n" ++
259 "\n" ++
260 " $p distrust {pkg-id}\n" ++
261 " Distrust the specified package.\n" ++
262 "\n" ++
263 " $p list [pkg]\n" ++
264 " List registered packages in the global database, and also the\n" ++
265 " user database if --user is given. If a package name is given\n" ++
266 " all the registered versions will be listed in ascending order.\n" ++
267 " Accepts the --simple-output flag.\n" ++
268 "\n" ++
269 " $p dot\n" ++
270 " Generate a graph of the package dependencies in a form suitable\n" ++
271 " for input for the graphviz tools. For example, to generate a PDF" ++
272 " of the dependency graph: ghc-pkg dot | tred | dot -Tpdf >pkgs.pdf" ++
273 "\n" ++
274 " $p find-module {module}\n" ++
275 " List registered packages exposing module {module} in the global\n" ++
276 " database, and also the user database if --user is given.\n" ++
277 " All the registered versions will be listed in ascending order.\n" ++
278 " Accepts the --simple-output flag.\n" ++
279 "\n" ++
280 " $p latest {pkg-id}\n" ++
281 " Prints the highest registered version of a package.\n" ++
282 "\n" ++
283 " $p check\n" ++
284 " Check the consistency of package dependencies and list broken packages.\n" ++
285 " Accepts the --simple-output flag.\n" ++
286 "\n" ++
287 " $p describe {pkg}\n" ++
288 " Give the registered description for the specified package. The\n" ++
289 " description is returned in precisely the syntax required by $p\n" ++
290 " register.\n" ++
291 "\n" ++
292 " $p field {pkg} {field}\n" ++
293 " Extract the specified field of the package description for the\n" ++
294 " specified package. Accepts comma-separated multiple fields.\n" ++
295 "\n" ++
296 " $p dump\n" ++
297 " Dump the registered description for every package. This is like\n" ++
298 " \"ghc-pkg describe '*'\", except that it is intended to be used\n" ++
299 " by tools that parse the results, rather than humans. The output is\n" ++
300 " always encoded in UTF-8, regardless of the current locale.\n" ++
301 "\n" ++
302 " $p recache\n" ++
303 " Regenerate the package database cache. This command should only be\n" ++
304 " necessary if you added a package to the database by dropping a file\n" ++
305 " into the database directory manually. By default, the global DB\n" ++
306 " is recached; to recache a different DB use --user or --package-db\n" ++
307 " as appropriate.\n" ++
308 "\n" ++
309 " Substring matching is supported for {module} in find-module and\n" ++
310 " for {pkg} in list, describe, and field, where a '*' indicates\n" ++
311 " open substring ends (prefix*, *suffix, *infix*). Use --ipid to\n" ++
312 " match against the installed package ID instead.\n" ++
313 "\n" ++
314 " When asked to modify a database (register, unregister, update,\n"++
315 " hide, expose, and also check), ghc-pkg modifies the global database by\n"++
316 " default. Specifying --user causes it to act on the user database,\n"++
317 " or --package-db can be used to act on another database\n"++
318 " entirely. When multiple of these options are given, the rightmost\n"++
319 " one is used as the database to act upon.\n"++
320 "\n"++
321 " Commands that query the package database (list, tree, latest, describe,\n"++
322 " field) operate on the list of databases specified by the flags\n"++
323 " --user, --global, and --package-db. If none of these flags are\n"++
324 " given, the default is --global --user.\n"++
325 "\n" ++
326 " The following optional flags are also accepted:\n"
327
328 substProg :: String -> String -> String
329 substProg _ [] = []
330 substProg prog ('$':'p':xs) = prog ++ substProg prog xs
331 substProg prog (c:xs) = c : substProg prog xs
332
333 -- -----------------------------------------------------------------------------
334 -- Do the business
335
336 data Force = NoForce | ForceFiles | ForceAll | CannotForce
337 deriving (Eq,Ord)
338
339 -- | Enum flag representing argument type
340 data AsPackageArg
341 = AsUnitId
342 | AsDefault
343
344 -- | Represents how a package may be specified by a user on the command line.
345 data PackageArg
346 -- | A package identifier foo-0.1, or a glob foo-*
347 = Id GlobPackageIdentifier
348 -- | An installed package ID foo-0.1-HASH. This is guaranteed to uniquely
349 -- match a single entry in the package database.
350 | IUId UnitId
351 -- | A glob against the package name. The first string is the literal
352 -- glob, the second is a function which returns @True@ if the argument
353 -- matches.
354 | Substring String (String->Bool)
355
356 runit :: Verbosity -> [Flag] -> [String] -> IO ()
357 runit verbosity cli nonopts = do
358 installSignalHandlers -- catch ^C and clean up
359 when (verbosity >= Verbose)
360 (putStr ourCopyright)
361 prog <- getProgramName
362 let
363 force
364 | FlagForce `elem` cli = ForceAll
365 | FlagForceFiles `elem` cli = ForceFiles
366 | otherwise = NoForce
367 as_arg | FlagUnitId `elem` cli = AsUnitId
368 | otherwise = AsDefault
369 multi_instance = FlagMultiInstance `elem` cli
370 expand_env_vars= FlagExpandEnvVars `elem` cli
371 mexpand_pkgroot= foldl' accumExpandPkgroot Nothing cli
372 where accumExpandPkgroot _ FlagExpandPkgroot = Just True
373 accumExpandPkgroot _ FlagNoExpandPkgroot = Just False
374 accumExpandPkgroot x _ = x
375
376 splitFields fields = unfoldr splitComma (',':fields)
377 where splitComma "" = Nothing
378 splitComma fs = Just $ break (==',') (tail fs)
379
380 -- | Parses a glob into a predicate which tests if a string matches
381 -- the glob. Returns Nothing if the string in question is not a glob.
382 -- At the moment, we only support globs at the beginning and/or end of
383 -- strings. This function respects case sensitivity.
384 --
385 -- >>> fromJust (substringCheck "*") "anything"
386 -- True
387 --
388 -- >>> fromJust (substringCheck "string") "string"
389 -- True
390 --
391 -- >>> fromJust (substringCheck "*bar") "foobar"
392 -- True
393 --
394 -- >>> fromJust (substringCheck "foo*") "foobar"
395 -- True
396 --
397 -- >>> fromJust (substringCheck "*ooba*") "foobar"
398 -- True
399 --
400 -- >>> fromJust (substringCheck "f*bar") "foobar"
401 -- False
402 substringCheck :: String -> Maybe (String -> Bool)
403 substringCheck "" = Nothing
404 substringCheck "*" = Just (const True)
405 substringCheck [_] = Nothing
406 substringCheck (h:t) =
407 case (h, init t, last t) of
408 ('*',s,'*') -> Just (isInfixOf (f s) . f)
409 ('*',_, _ ) -> Just (isSuffixOf (f t) . f)
410 ( _ ,s,'*') -> Just (isPrefixOf (f (h:s)) . f)
411 _ -> Nothing
412 where f | FlagIgnoreCase `elem` cli = map toLower
413 | otherwise = id
414 #if defined(GLOB)
415 glob x | System.Info.os=="mingw32" = do
416 -- glob echoes its argument, after win32 filename globbing
417 (_,o,_,_) <- runInteractiveCommand ("glob "++x)
418 txt <- hGetContents o
419 return (read txt)
420 glob x | otherwise = return [x]
421 #endif
422 --
423 -- first, parse the command
424 case nonopts of
425 #if defined(GLOB)
426 -- dummy command to demonstrate usage and permit testing
427 -- without messing things up; use glob to selectively enable
428 -- windows filename globbing for file parameters
429 -- register, update, FlagGlobalConfig, FlagConfig; others?
430 ["glob", filename] -> do
431 print filename
432 glob filename >>= print
433 #endif
434 ["init", filename] ->
435 initPackageDB filename verbosity cli
436 ["register", filename] ->
437 registerPackage filename verbosity cli
438 multi_instance
439 expand_env_vars False force
440 ["update", filename] ->
441 registerPackage filename verbosity cli
442 multi_instance
443 expand_env_vars True force
444 "unregister" : pkgarg_strs@(_:_) -> do
445 forM_ pkgarg_strs $ \pkgarg_str -> do
446 pkgarg <- readPackageArg as_arg pkgarg_str
447 unregisterPackage pkgarg verbosity cli force
448 ["expose", pkgarg_str] -> do
449 pkgarg <- readPackageArg as_arg pkgarg_str
450 exposePackage pkgarg verbosity cli force
451 ["hide", pkgarg_str] -> do
452 pkgarg <- readPackageArg as_arg pkgarg_str
453 hidePackage pkgarg verbosity cli force
454 ["trust", pkgarg_str] -> do
455 pkgarg <- readPackageArg as_arg pkgarg_str
456 trustPackage pkgarg verbosity cli force
457 ["distrust", pkgarg_str] -> do
458 pkgarg <- readPackageArg as_arg pkgarg_str
459 distrustPackage pkgarg verbosity cli force
460 ["list"] -> do
461 listPackages verbosity cli Nothing Nothing
462 ["list", pkgarg_str] ->
463 case substringCheck pkgarg_str of
464 Nothing -> do pkgarg <- readPackageArg as_arg pkgarg_str
465 listPackages verbosity cli (Just pkgarg) Nothing
466 Just m -> listPackages verbosity cli
467 (Just (Substring pkgarg_str m)) Nothing
468 ["dot"] -> do
469 showPackageDot verbosity cli
470 ["find-module", mod_name] -> do
471 let match = maybe (==mod_name) id (substringCheck mod_name)
472 listPackages verbosity cli Nothing (Just match)
473 ["latest", pkgid_str] -> do
474 pkgid <- readGlobPkgId pkgid_str
475 latestPackage verbosity cli pkgid
476 ["describe", pkgid_str] -> do
477 pkgarg <- case substringCheck pkgid_str of
478 Nothing -> readPackageArg as_arg pkgid_str
479 Just m -> return (Substring pkgid_str m)
480 describePackage verbosity cli pkgarg (fromMaybe False mexpand_pkgroot)
481
482 ["field", pkgid_str, fields] -> do
483 pkgarg <- case substringCheck pkgid_str of
484 Nothing -> readPackageArg as_arg pkgid_str
485 Just m -> return (Substring pkgid_str m)
486 describeField verbosity cli pkgarg
487 (splitFields fields) (fromMaybe True mexpand_pkgroot)
488
489 ["check"] -> do
490 checkConsistency verbosity cli
491
492 ["dump"] -> do
493 dumpPackages verbosity cli (fromMaybe False mexpand_pkgroot)
494
495 ["recache"] -> do
496 recache verbosity cli
497
498 [] -> do
499 die ("missing command\n" ++ shortUsage prog)
500 (_cmd:_) -> do
501 die ("command-line syntax error\n" ++ shortUsage prog)
502
503 parseCheck :: ReadP a a -> String -> String -> IO a
504 parseCheck parser str what =
505 case [ x | (x,ys) <- readP_to_S parser str, all isSpace ys ] of
506 [x] -> return x
507 _ -> die ("cannot parse \'" ++ str ++ "\' as a " ++ what)
508
509 -- | Either an exact 'PackageIdentifier', or a glob for all packages
510 -- matching 'PackageName'.
511 data GlobPackageIdentifier
512 = ExactPackageIdentifier PackageIdentifier
513 | GlobPackageIdentifier PackageName
514
515 displayGlobPkgId :: GlobPackageIdentifier -> String
516 displayGlobPkgId (ExactPackageIdentifier pid) = display pid
517 displayGlobPkgId (GlobPackageIdentifier pn) = display pn ++ "-*"
518
519 readGlobPkgId :: String -> IO GlobPackageIdentifier
520 readGlobPkgId str = parseCheck parseGlobPackageId str "package identifier"
521
522 parseGlobPackageId :: ReadP r GlobPackageIdentifier
523 parseGlobPackageId =
524 fmap ExactPackageIdentifier parse
525 +++
526 (do n <- parse
527 _ <- string "-*"
528 return (GlobPackageIdentifier n))
529
530 readPackageArg :: AsPackageArg -> String -> IO PackageArg
531 readPackageArg AsUnitId str =
532 parseCheck (IUId `fmap` parse) str "installed package id"
533 readPackageArg AsDefault str = Id `fmap` readGlobPkgId str
534
535 -- -----------------------------------------------------------------------------
536 -- Package databases
537
538 -- Some commands operate on a single database:
539 -- register, unregister, expose, hide, trust, distrust
540 -- however these commands also check the union of the available databases
541 -- in order to check consistency. For example, register will check that
542 -- dependencies exist before registering a package.
543 --
544 -- Some commands operate on multiple databases, with overlapping semantics:
545 -- list, describe, field
546
547 data PackageDB (mode :: GhcPkg.DbMode)
548 = PackageDB {
549 location, locationAbsolute :: !FilePath,
550 -- We need both possibly-relative and definitely-absolute package
551 -- db locations. This is because the relative location is used as
552 -- an identifier for the db, so it is important we do not modify it.
553 -- On the other hand we need the absolute path in a few places
554 -- particularly in relation to the ${pkgroot} stuff.
555
556 packageDbLock :: !(GhcPkg.DbOpenMode mode GhcPkg.PackageDbLock),
557 -- If package db is open in read write mode, we keep its lock around for
558 -- transactional updates.
559
560 packages :: [InstalledPackageInfo]
561 }
562
563 type PackageDBStack = [PackageDB 'GhcPkg.DbReadOnly]
564 -- A stack of package databases. Convention: head is the topmost
565 -- in the stack.
566
567 -- | Selector for picking the right package DB to modify as 'register' and
568 -- 'recache' operate on the database on top of the stack, whereas 'modify'
569 -- changes the first database that contains a specific package.
570 data DbModifySelector = TopOne | ContainsPkg PackageArg
571
572 allPackagesInStack :: PackageDBStack -> [InstalledPackageInfo]
573 allPackagesInStack = concatMap packages
574
575 getPkgDatabases :: Verbosity
576 -> GhcPkg.DbOpenMode mode DbModifySelector
577 -> Bool -- use the user db
578 -> Bool -- read caches, if available
579 -> Bool -- expand vars, like ${pkgroot} and $topdir
580 -> [Flag]
581 -> IO (PackageDBStack,
582 -- the real package DB stack: [global,user] ++
583 -- DBs specified on the command line with -f.
584 GhcPkg.DbOpenMode mode (PackageDB mode),
585 -- which one to modify, if any
586 PackageDBStack)
587 -- the package DBs specified on the command
588 -- line, or [global,user] otherwise. This
589 -- is used as the list of package DBs for
590 -- commands that just read the DB, such as 'list'.
591
592 getPkgDatabases verbosity mode use_user use_cache expand_vars my_flags = do
593 -- first we determine the location of the global package config. On Windows,
594 -- this is found relative to the ghc-pkg.exe binary, whereas on Unix the
595 -- location is passed to the binary using the --global-package-db flag by the
596 -- wrapper script.
597 let err_msg = "missing --global-package-db option, location of global package database unknown\n"
598 global_conf <-
599 case [ f | FlagGlobalConfig f <- my_flags ] of
600 [] -> do mb_dir <- getLibDir
601 case mb_dir of
602 Nothing -> die err_msg
603 Just dir -> do
604 r <- lookForPackageDBIn dir
605 case r of
606 Nothing -> die ("Can't find package database in " ++ dir)
607 Just path -> return path
608 fs -> return (last fs)
609
610 -- The value of the $topdir variable used in some package descriptions
611 -- Note that the way we calculate this is slightly different to how it
612 -- is done in ghc itself. We rely on the convention that the global
613 -- package db lives in ghc's libdir.
614 top_dir <- absolutePath (takeDirectory global_conf)
615
616 let no_user_db = FlagNoUserDb `elem` my_flags
617
618 -- get the location of the user package database, and create it if necessary
619 -- getAppUserDataDirectory can fail (e.g. if $HOME isn't set)
620 e_appdir <- tryIO $ getAppUserDataDirectory "ghc"
621
622 mb_user_conf <-
623 case [ f | FlagUserConfig f <- my_flags ] of
624 _ | no_user_db -> return Nothing
625 [] -> case e_appdir of
626 Left _ -> return Nothing
627 Right appdir -> do
628 let subdir = targetARCH ++ '-':targetOS ++ '-':Version.version
629 dir = appdir </> subdir
630 r <- lookForPackageDBIn dir
631 case r of
632 Nothing -> return (Just (dir </> "package.conf.d", False))
633 Just f -> return (Just (f, True))
634 fs -> return (Just (last fs, True))
635
636 -- If the user database exists, and for "use_user" commands (which includes
637 -- "ghc-pkg check" and all commands that modify the db) we will attempt to
638 -- use the user db.
639 let sys_databases
640 | Just (user_conf,user_exists) <- mb_user_conf,
641 use_user || user_exists = [user_conf, global_conf]
642 | otherwise = [global_conf]
643
644 e_pkg_path <- tryIO (System.Environment.getEnv "GHC_PACKAGE_PATH")
645 let env_stack =
646 case e_pkg_path of
647 Left _ -> sys_databases
648 Right path
649 | not (null path) && isSearchPathSeparator (last path)
650 -> splitSearchPath (init path) ++ sys_databases
651 | otherwise
652 -> splitSearchPath path
653
654 -- The "global" database is always the one at the bottom of the stack.
655 -- This is the database we modify by default.
656 virt_global_conf = last env_stack
657
658 let db_flags = [ f | Just f <- map is_db_flag my_flags ]
659 where is_db_flag FlagUser
660 | Just (user_conf, _user_exists) <- mb_user_conf
661 = Just user_conf
662 is_db_flag FlagGlobal = Just virt_global_conf
663 is_db_flag (FlagConfig f) = Just f
664 is_db_flag _ = Nothing
665
666 let flag_db_names | null db_flags = env_stack
667 | otherwise = reverse (nub db_flags)
668
669 -- For a "modify" command, treat all the databases as
670 -- a stack, where we are modifying the top one, but it
671 -- can refer to packages in databases further down the
672 -- stack.
673
674 -- -f flags on the command line add to the database
675 -- stack, unless any of them are present in the stack
676 -- already.
677 let final_stack = filter (`notElem` env_stack)
678 [ f | FlagConfig f <- reverse my_flags ]
679 ++ env_stack
680
681 top_db = if null db_flags
682 then virt_global_conf
683 else last db_flags
684
685 (db_stack, db_to_operate_on) <- getDatabases top_dir mb_user_conf
686 flag_db_names final_stack top_db
687
688 let flag_db_stack = [ db | db_name <- flag_db_names,
689 db <- db_stack, location db == db_name ]
690
691 when (verbosity > Normal) $ do
692 infoLn ("db stack: " ++ show (map location db_stack))
693 F.forM_ db_to_operate_on $ \db ->
694 infoLn ("modifying: " ++ (location db))
695 infoLn ("flag db stack: " ++ show (map location flag_db_stack))
696
697 return (db_stack, db_to_operate_on, flag_db_stack)
698 where
699 getDatabases top_dir mb_user_conf flag_db_names
700 final_stack top_db = case mode of
701 -- When we open in read only mode, we simply read all of the databases/
702 GhcPkg.DbOpenReadOnly -> do
703 db_stack <- mapM readDatabase final_stack
704 return (db_stack, GhcPkg.DbOpenReadOnly)
705
706 -- The only package db we open in read write mode is the one on the top of
707 -- the stack.
708 GhcPkg.DbOpenReadWrite TopOne -> do
709 (db_stack, mto_modify) <- stateSequence Nothing
710 [ \case
711 to_modify@(Just _) -> (, to_modify) <$> readDatabase db_path
712 Nothing -> if db_path /= top_db
713 then (, Nothing) <$> readDatabase db_path
714 else do
715 db <- readParseDatabase verbosity mb_user_conf
716 mode use_cache db_path
717 `Exception.catch` couldntOpenDbForModification db_path
718 let ro_db = db { packageDbLock = GhcPkg.DbOpenReadOnly }
719 return (ro_db, Just db)
720 | db_path <- final_stack ]
721
722 to_modify <- case mto_modify of
723 Just db -> return db
724 Nothing -> die "no database selected for modification"
725
726 return (db_stack, GhcPkg.DbOpenReadWrite to_modify)
727
728 -- The package db we open in read write mode is the first one included in
729 -- flag_db_names that contains specified package. Therefore we need to
730 -- open each one in read/write mode first and decide whether it's for
731 -- modification based on its contents.
732 GhcPkg.DbOpenReadWrite (ContainsPkg pkgarg) -> do
733 (db_stack, mto_modify) <- stateSequence Nothing
734 [ \case
735 to_modify@(Just _) -> (, to_modify) <$> readDatabase db_path
736 Nothing -> if db_path `notElem` flag_db_names
737 then (, Nothing) <$> readDatabase db_path
738 else do
739 let hasPkg :: PackageDB mode -> Bool
740 hasPkg = not . null . findPackage pkgarg . packages
741
742 openRo (e::IOError) = do
743 db <- readDatabase db_path
744 if hasPkg db
745 then couldntOpenDbForModification db_path e
746 else return (db, Nothing)
747
748 -- If we fail to open the database in read/write mode, we need
749 -- to check if it's for modification first before throwing an
750 -- error, so we attempt to open it in read only mode.
751 Exception.handle openRo $ do
752 db <- readParseDatabase verbosity mb_user_conf
753 mode use_cache db_path
754 let ro_db = db { packageDbLock = GhcPkg.DbOpenReadOnly }
755 if hasPkg db
756 then return (ro_db, Just db)
757 else do
758 -- If the database is not for modification after all,
759 -- drop the write lock as we are already finished with
760 -- the database.
761 case packageDbLock db of
762 GhcPkg.DbOpenReadWrite lock ->
763 GhcPkg.unlockPackageDb lock
764 return (ro_db, Nothing)
765 | db_path <- final_stack ]
766
767 to_modify <- case mto_modify of
768 Just db -> return db
769 Nothing -> cannotFindPackage pkgarg Nothing
770
771 return (db_stack, GhcPkg.DbOpenReadWrite to_modify)
772 where
773 couldntOpenDbForModification :: FilePath -> IOError -> IO a
774 couldntOpenDbForModification db_path e = die $ "Couldn't open database "
775 ++ db_path ++ " for modification: " ++ show e
776
777 -- Parse package db in read-only mode.
778 readDatabase :: FilePath -> IO (PackageDB 'GhcPkg.DbReadOnly)
779 readDatabase db_path = do
780 db <- readParseDatabase verbosity mb_user_conf
781 GhcPkg.DbOpenReadOnly use_cache db_path
782 if expand_vars
783 then return $ mungePackageDBPaths top_dir db
784 else return db
785
786 stateSequence :: Monad m => s -> [s -> m (a, s)] -> m ([a], s)
787 stateSequence s [] = return ([], s)
788 stateSequence s (m:ms) = do
789 (a, s') <- m s
790 (as, s'') <- stateSequence s' ms
791 return (a : as, s'')
792
793 lookForPackageDBIn :: FilePath -> IO (Maybe FilePath)
794 lookForPackageDBIn dir = do
795 let path_dir = dir </> "package.conf.d"
796 exists_dir <- doesDirectoryExist path_dir
797 if exists_dir then return (Just path_dir) else do
798 let path_file = dir </> "package.conf"
799 exists_file <- doesFileExist path_file
800 if exists_file then return (Just path_file) else return Nothing
801
802 readParseDatabase :: forall mode t. Verbosity
803 -> Maybe (FilePath,Bool)
804 -> GhcPkg.DbOpenMode mode t
805 -> Bool -- use cache
806 -> FilePath
807 -> IO (PackageDB mode)
808 readParseDatabase verbosity mb_user_conf mode use_cache path
809 -- the user database (only) is allowed to be non-existent
810 | Just (user_conf,False) <- mb_user_conf, path == user_conf
811 = do lock <- F.forM mode $ \_ -> do
812 createDirectoryIfMissing True path
813 GhcPkg.lockPackageDb cache
814 mkPackageDB [] lock
815 | otherwise
816 = do e <- tryIO $ getDirectoryContents path
817 case e of
818 Left err
819 | ioeGetErrorType err == InappropriateType -> do
820 -- We provide a limited degree of backwards compatibility for
821 -- old single-file style db:
822 mdb <- tryReadParseOldFileStyleDatabase verbosity
823 mb_user_conf mode use_cache path
824 case mdb of
825 Just db -> return db
826 Nothing ->
827 die $ "ghc no longer supports single-file style package "
828 ++ "databases (" ++ path ++ ") use 'ghc-pkg init'"
829 ++ "to create the database with the correct format."
830
831 | otherwise -> ioError err
832 Right fs
833 | not use_cache -> ignore_cache (const $ return ())
834 | otherwise -> do
835 tdir <- getModificationTime path
836 e_tcache <- tryIO $ getModificationTime cache
837 case e_tcache of
838 Left ex -> do
839 whenReportCacheErrors $
840 if isDoesNotExistError ex
841 then
842 when (verbosity >= Verbose) $ do
843 warn ("WARNING: cache does not exist: " ++ cache)
844 warn ("ghc will fail to read this package db. " ++
845 recacheAdvice)
846 else do
847 warn ("WARNING: cache cannot be read: " ++ show ex)
848 warn "ghc will fail to read this package db."
849 ignore_cache (const $ return ())
850 Right tcache -> do
851 let compareTimestampToCache file =
852 when (verbosity >= Verbose) $ do
853 tFile <- getModificationTime file
854 compareTimestampToCache' file tFile
855 compareTimestampToCache' file tFile = do
856 let rel = case tcache `compare` tFile of
857 LT -> " (NEWER than cache)"
858 GT -> " (older than cache)"
859 EQ -> " (same as cache)"
860 warn ("Timestamp " ++ show tFile
861 ++ " for " ++ file ++ rel)
862 when (verbosity >= Verbose) $ do
863 warn ("Timestamp " ++ show tcache ++ " for " ++ cache)
864 compareTimestampToCache' path tdir
865 if tcache >= tdir
866 then do
867 when (verbosity > Normal) $
868 infoLn ("using cache: " ++ cache)
869 GhcPkg.readPackageDbForGhcPkg cache mode
870 >>= uncurry mkPackageDB
871 else do
872 whenReportCacheErrors $ do
873 warn ("WARNING: cache is out of date: " ++ cache)
874 warn ("ghc will see an old view of this " ++
875 "package db. " ++ recacheAdvice)
876 ignore_cache compareTimestampToCache
877 where
878 ignore_cache :: (FilePath -> IO ()) -> IO (PackageDB mode)
879 ignore_cache checkTime = do
880 -- If we're opening for modification, we need to acquire a
881 -- lock even if we don't open the cache now, because we are
882 -- going to modify it later.
883 lock <- F.mapM (const $ GhcPkg.lockPackageDb cache) mode
884 let confs = filter (".conf" `isSuffixOf`) fs
885 doFile f = do checkTime f
886 parseSingletonPackageConf verbosity f
887 pkgs <- mapM doFile $ map (path </>) confs
888 mkPackageDB pkgs lock
889
890 -- We normally report cache errors for read-only commands,
891 -- since modify commands will usually fix the cache.
892 whenReportCacheErrors = when $ verbosity > Normal
893 || verbosity >= Normal && GhcPkg.isDbOpenReadMode mode
894 where
895 cache = path </> cachefilename
896
897 recacheAdvice
898 | Just (user_conf, True) <- mb_user_conf, path == user_conf
899 = "Use 'ghc-pkg recache --user' to fix."
900 | otherwise
901 = "Use 'ghc-pkg recache' to fix."
902
903 mkPackageDB :: [InstalledPackageInfo]
904 -> GhcPkg.DbOpenMode mode GhcPkg.PackageDbLock
905 -> IO (PackageDB mode)
906 mkPackageDB pkgs lock = do
907 path_abs <- absolutePath path
908 return $ PackageDB {
909 location = path,
910 locationAbsolute = path_abs,
911 packageDbLock = lock,
912 packages = pkgs
913 }
914
915 parseSingletonPackageConf :: Verbosity -> FilePath -> IO InstalledPackageInfo
916 parseSingletonPackageConf verbosity file = do
917 when (verbosity > Normal) $ infoLn ("reading package config: " ++ file)
918 readUTF8File file >>= fmap fst . parsePackageInfo
919
920 cachefilename :: FilePath
921 cachefilename = "package.cache"
922
923 mungePackageDBPaths :: FilePath -> PackageDB mode -> PackageDB mode
924 mungePackageDBPaths top_dir db@PackageDB { packages = pkgs } =
925 db { packages = map (mungePackagePaths top_dir pkgroot) pkgs }
926 where
927 pkgroot = takeDirectory $ dropTrailingPathSeparator (locationAbsolute db)
928 -- It so happens that for both styles of package db ("package.conf"
929 -- files and "package.conf.d" dirs) the pkgroot is the parent directory
930 -- ${pkgroot}/package.conf or ${pkgroot}/package.conf.d/
931
932 -- TODO: This code is duplicated in compiler/main/Packages.hs
933 mungePackagePaths :: FilePath -> FilePath
934 -> InstalledPackageInfo -> InstalledPackageInfo
935 -- Perform path/URL variable substitution as per the Cabal ${pkgroot} spec
936 -- (http://www.haskell.org/pipermail/libraries/2009-May/011772.html)
937 -- Paths/URLs can be relative to ${pkgroot} or ${pkgrooturl}.
938 -- The "pkgroot" is the directory containing the package database.
939 --
940 -- Also perform a similar substitution for the older GHC-specific
941 -- "$topdir" variable. The "topdir" is the location of the ghc
942 -- installation (obtained from the -B option).
943 mungePackagePaths top_dir pkgroot pkg =
944 pkg {
945 importDirs = munge_paths (importDirs pkg),
946 includeDirs = munge_paths (includeDirs pkg),
947 libraryDirs = munge_paths (libraryDirs pkg),
948 libraryDynDirs = munge_paths (libraryDynDirs pkg),
949 frameworkDirs = munge_paths (frameworkDirs pkg),
950 haddockInterfaces = munge_paths (haddockInterfaces pkg),
951 -- haddock-html is allowed to be either a URL or a file
952 haddockHTMLs = munge_paths (munge_urls (haddockHTMLs pkg))
953 }
954 where
955 munge_paths = map munge_path
956 munge_urls = map munge_url
957
958 munge_path p
959 | Just p' <- stripVarPrefix "${pkgroot}" p = pkgroot ++ p'
960 | Just p' <- stripVarPrefix "$topdir" p = top_dir ++ p'
961 | otherwise = p
962
963 munge_url p
964 | Just p' <- stripVarPrefix "${pkgrooturl}" p = toUrlPath pkgroot p'
965 | Just p' <- stripVarPrefix "$httptopdir" p = toUrlPath top_dir p'
966 | otherwise = p
967
968 toUrlPath r p = "file:///"
969 -- URLs always use posix style '/' separators:
970 ++ FilePath.Posix.joinPath
971 (r : -- We need to drop a leading "/" or "\\"
972 -- if there is one:
973 dropWhile (all isPathSeparator)
974 (FilePath.splitDirectories p))
975
976 -- We could drop the separator here, and then use </> above. However,
977 -- by leaving it in and using ++ we keep the same path separator
978 -- rather than letting FilePath change it to use \ as the separator
979 stripVarPrefix var path = case stripPrefix var path of
980 Just [] -> Just []
981 Just cs@(c : _) | isPathSeparator c -> Just cs
982 _ -> Nothing
983
984
985 -- -----------------------------------------------------------------------------
986 -- Workaround for old single-file style package dbs
987
988 -- Single-file style package dbs have been deprecated for some time, but
989 -- it turns out that Cabal was using them in one place. So this code is for a
990 -- workaround to allow older Cabal versions to use this newer ghc.
991
992 -- We check if the file db contains just "[]" and if so, we look for a new
993 -- dir-style db in path.d/, ie in a dir next to the given file.
994 -- We cannot just replace the file with a new dir style since Cabal still
995 -- assumes it's a file and tries to overwrite with 'writeFile'.
996
997 -- ghc itself also cooperates in this workaround
998
999 tryReadParseOldFileStyleDatabase :: Verbosity -> Maybe (FilePath, Bool)
1000 -> GhcPkg.DbOpenMode mode t -> Bool -> FilePath
1001 -> IO (Maybe (PackageDB mode))
1002 tryReadParseOldFileStyleDatabase verbosity mb_user_conf
1003 mode use_cache path = do
1004 -- assumes we've already established that path exists and is not a dir
1005 content <- readFile path `catchIO` \_ -> return ""
1006 if take 2 content == "[]"
1007 then do
1008 path_abs <- absolutePath path
1009 let path_dir = adjustOldDatabasePath path
1010 warn $ "Warning: ignoring old file-style db and trying " ++ path_dir
1011 direxists <- doesDirectoryExist path_dir
1012 if direxists
1013 then do
1014 db <- readParseDatabase verbosity mb_user_conf mode use_cache path_dir
1015 -- but pretend it was at the original location
1016 return $ Just db {
1017 location = path,
1018 locationAbsolute = path_abs
1019 }
1020 else do
1021 lock <- F.forM mode $ \_ -> do
1022 createDirectoryIfMissing True path_dir
1023 GhcPkg.lockPackageDb $ path_dir </> cachefilename
1024 return $ Just PackageDB {
1025 location = path,
1026 locationAbsolute = path_abs,
1027 packageDbLock = lock,
1028 packages = []
1029 }
1030
1031 -- if the path is not a file, or is not an empty db then we fail
1032 else return Nothing
1033
1034 adjustOldFileStylePackageDB :: PackageDB mode -> IO (PackageDB mode)
1035 adjustOldFileStylePackageDB db = do
1036 -- assumes we have not yet established if it's an old style or not
1037 mcontent <- liftM Just (readFile (location db)) `catchIO` \_ -> return Nothing
1038 case fmap (take 2) mcontent of
1039 -- it is an old style and empty db, so look for a dir kind in location.d/
1040 Just "[]" -> return db {
1041 location = adjustOldDatabasePath $ location db,
1042 locationAbsolute = adjustOldDatabasePath $ locationAbsolute db
1043 }
1044 -- it is old style but not empty, we have to bail
1045 Just _ -> die $ "ghc no longer supports single-file style package "
1046 ++ "databases (" ++ location db ++ ") use 'ghc-pkg init'"
1047 ++ "to create the database with the correct format."
1048 -- probably not old style, carry on as normal
1049 Nothing -> return db
1050
1051 adjustOldDatabasePath :: FilePath -> FilePath
1052 adjustOldDatabasePath = (<.> "d")
1053
1054 -- -----------------------------------------------------------------------------
1055 -- Creating a new package DB
1056
1057 initPackageDB :: FilePath -> Verbosity -> [Flag] -> IO ()
1058 initPackageDB filename verbosity _flags = do
1059 let eexist = die ("cannot create: " ++ filename ++ " already exists")
1060 b1 <- doesFileExist filename
1061 when b1 eexist
1062 b2 <- doesDirectoryExist filename
1063 when b2 eexist
1064 createDirectoryIfMissing True filename
1065 lock <- GhcPkg.lockPackageDb $ filename </> cachefilename
1066 filename_abs <- absolutePath filename
1067 changeDB verbosity [] PackageDB {
1068 location = filename,
1069 locationAbsolute = filename_abs,
1070 packageDbLock = GhcPkg.DbOpenReadWrite lock,
1071 packages = []
1072 }
1073
1074 -- -----------------------------------------------------------------------------
1075 -- Registering
1076
1077 registerPackage :: FilePath
1078 -> Verbosity
1079 -> [Flag]
1080 -> Bool -- multi_instance
1081 -> Bool -- expand_env_vars
1082 -> Bool -- update
1083 -> Force
1084 -> IO ()
1085 registerPackage input verbosity my_flags multi_instance
1086 expand_env_vars update force = do
1087 (db_stack, GhcPkg.DbOpenReadWrite db_to_operate_on, _flag_dbs) <-
1088 getPkgDatabases verbosity (GhcPkg.DbOpenReadWrite TopOne)
1089 True{-use user-} True{-use cache-} False{-expand vars-} my_flags
1090
1091 let to_modify = location db_to_operate_on
1092
1093 s <-
1094 case input of
1095 "-" -> do
1096 when (verbosity >= Normal) $
1097 info "Reading package info from stdin ... "
1098 -- fix the encoding to UTF-8, since this is an interchange format
1099 hSetEncoding stdin utf8
1100 getContents
1101 f -> do
1102 when (verbosity >= Normal) $
1103 info ("Reading package info from " ++ show f ++ " ... ")
1104 readUTF8File f
1105
1106 expanded <- if expand_env_vars then expandEnvVars s force
1107 else return s
1108
1109 (pkg, ws) <- parsePackageInfo expanded
1110 when (verbosity >= Normal) $
1111 infoLn "done."
1112
1113 -- report any warnings from the parse phase
1114 _ <- reportValidateErrors verbosity [] ws
1115 (display (sourcePackageId pkg) ++ ": Warning: ") Nothing
1116
1117 -- validate the expanded pkg, but register the unexpanded
1118 pkgroot <- absolutePath (takeDirectory to_modify)
1119 let top_dir = takeDirectory (location (last db_stack))
1120 pkg_expanded = mungePackagePaths top_dir pkgroot pkg
1121
1122 let truncated_stack = dropWhile ((/= to_modify).location) db_stack
1123 -- truncate the stack for validation, because we don't allow
1124 -- packages lower in the stack to refer to those higher up.
1125 validatePackageConfig pkg_expanded verbosity truncated_stack
1126 multi_instance update force
1127
1128 let
1129 -- In the normal mode, we only allow one version of each package, so we
1130 -- remove all instances with the same source package id as the one we're
1131 -- adding. In the multi instance mode we don't do that, thus allowing
1132 -- multiple instances with the same source package id.
1133 removes = [ RemovePackage p
1134 | not multi_instance,
1135 p <- packages db_to_operate_on,
1136 sourcePackageId p == sourcePackageId pkg,
1137 -- Only remove things that were instantiated the same way!
1138 instantiatedWith p == instantiatedWith pkg ]
1139 --
1140 changeDB verbosity (removes ++ [AddPackage pkg]) db_to_operate_on
1141
1142 parsePackageInfo
1143 :: String
1144 -> IO (InstalledPackageInfo, [ValidateWarning])
1145 parsePackageInfo str =
1146 case parseInstalledPackageInfo str of
1147 ParseOk warnings ok -> return (mungePackageInfo ok, ws)
1148 where
1149 ws = [ msg | PWarning msg <- warnings
1150 , not ("Unrecognized field pkgroot" `isPrefixOf` msg) ]
1151 ParseFailed err -> case locatedErrorMsg err of
1152 (Nothing, s) -> die s
1153 (Just l, s) -> die (show l ++ ": " ++ s)
1154
1155 mungePackageInfo :: InstalledPackageInfo -> InstalledPackageInfo
1156 mungePackageInfo ipi = ipi
1157
1158 -- -----------------------------------------------------------------------------
1159 -- Making changes to a package database
1160
1161 data DBOp = RemovePackage InstalledPackageInfo
1162 | AddPackage InstalledPackageInfo
1163 | ModifyPackage InstalledPackageInfo
1164
1165 changeDB :: Verbosity -> [DBOp] -> PackageDB 'GhcPkg.DbReadWrite -> IO ()
1166 changeDB verbosity cmds db = do
1167 let db' = updateInternalDB db cmds
1168 db'' <- adjustOldFileStylePackageDB db'
1169 createDirectoryIfMissing True (location db'')
1170 changeDBDir verbosity cmds db''
1171
1172 updateInternalDB :: PackageDB 'GhcPkg.DbReadWrite
1173 -> [DBOp] -> PackageDB 'GhcPkg.DbReadWrite
1174 updateInternalDB db cmds = db{ packages = foldl do_cmd (packages db) cmds }
1175 where
1176 do_cmd pkgs (RemovePackage p) =
1177 filter ((/= installedUnitId p) . installedUnitId) pkgs
1178 do_cmd pkgs (AddPackage p) = p : pkgs
1179 do_cmd pkgs (ModifyPackage p) =
1180 do_cmd (do_cmd pkgs (RemovePackage p)) (AddPackage p)
1181
1182
1183 changeDBDir :: Verbosity -> [DBOp] -> PackageDB 'GhcPkg.DbReadWrite -> IO ()
1184 changeDBDir verbosity cmds db = do
1185 mapM_ do_cmd cmds
1186 updateDBCache verbosity db
1187 where
1188 do_cmd (RemovePackage p) = do
1189 let file = location db </> display (installedUnitId p) <.> "conf"
1190 when (verbosity > Normal) $ infoLn ("removing " ++ file)
1191 removeFileSafe file
1192 do_cmd (AddPackage p) = do
1193 let file = location db </> display (installedUnitId p) <.> "conf"
1194 when (verbosity > Normal) $ infoLn ("writing " ++ file)
1195 writeUTF8File file (showInstalledPackageInfo p)
1196 do_cmd (ModifyPackage p) =
1197 do_cmd (AddPackage p)
1198
1199 updateDBCache :: Verbosity -> PackageDB 'GhcPkg.DbReadWrite -> IO ()
1200 updateDBCache verbosity db = do
1201 let filename = location db </> cachefilename
1202
1203 pkgsCabalFormat :: [InstalledPackageInfo]
1204 pkgsCabalFormat = packages db
1205
1206 pkgsGhcCacheFormat :: [PackageCacheFormat]
1207 pkgsGhcCacheFormat = map convertPackageInfoToCacheFormat pkgsCabalFormat
1208
1209 when (verbosity > Normal) $
1210 infoLn ("writing cache " ++ filename)
1211
1212 GhcPkg.writePackageDb filename pkgsGhcCacheFormat pkgsCabalFormat
1213 `catchIO` \e ->
1214 if isPermissionError e
1215 then die $ filename ++ ": you don't have permission to modify this file"
1216 else ioError e
1217
1218 -- See Note [writeAtomic leaky abstraction]
1219 -- Cross-platform "touch". This only works if filename is not empty, and
1220 -- not open for writing already.
1221 -- TODO. When the Win32 or directory packages have either a touchFile or a
1222 -- setModificationTime function, use one of those.
1223 withBinaryFile filename ReadWriteMode $ \handle -> do
1224 c <- hGetChar handle
1225 hSeek handle AbsoluteSeek 0
1226 hPutChar handle c
1227
1228 case packageDbLock db of
1229 GhcPkg.DbOpenReadWrite lock -> GhcPkg.unlockPackageDb lock
1230
1231 type PackageCacheFormat = GhcPkg.InstalledPackageInfo
1232 ComponentId
1233 PackageIdentifier
1234 PackageName
1235 UnitId
1236 OpenUnitId
1237 ModuleName
1238 OpenModule
1239
1240 convertPackageInfoToCacheFormat :: InstalledPackageInfo -> PackageCacheFormat
1241 convertPackageInfoToCacheFormat pkg =
1242 GhcPkg.InstalledPackageInfo {
1243 GhcPkg.unitId = installedUnitId pkg,
1244 GhcPkg.componentId = installedComponentId pkg,
1245 GhcPkg.instantiatedWith = instantiatedWith pkg,
1246 GhcPkg.sourcePackageId = sourcePackageId pkg,
1247 GhcPkg.packageName =
1248 case sourcePackageName pkg of
1249 Nothing -> packageName pkg
1250 Just pn -> pn,
1251 GhcPkg.packageVersion = Version.Version (versionNumbers (packageVersion pkg)) [],
1252 GhcPkg.mungedPackageName =
1253 case sourcePackageName pkg of
1254 Nothing -> Nothing
1255 Just _ -> Just (packageName pkg),
1256 GhcPkg.libName =
1257 fmap (mkPackageName . unUnqualComponentName) (sourceLibName pkg),
1258 GhcPkg.depends = depends pkg,
1259 GhcPkg.abiDepends = map (\(AbiDependency k v) -> (k,unAbiHash v)) (abiDepends pkg),
1260 GhcPkg.abiHash = unAbiHash (abiHash pkg),
1261 GhcPkg.importDirs = importDirs pkg,
1262 GhcPkg.hsLibraries = hsLibraries pkg,
1263 GhcPkg.extraLibraries = extraLibraries pkg,
1264 GhcPkg.extraGHCiLibraries = extraGHCiLibraries pkg,
1265 GhcPkg.libraryDirs = libraryDirs pkg,
1266 GhcPkg.libraryDynDirs = libraryDynDirs pkg,
1267 GhcPkg.frameworks = frameworks pkg,
1268 GhcPkg.frameworkDirs = frameworkDirs pkg,
1269 GhcPkg.ldOptions = ldOptions pkg,
1270 GhcPkg.ccOptions = ccOptions pkg,
1271 GhcPkg.includes = includes pkg,
1272 GhcPkg.includeDirs = includeDirs pkg,
1273 GhcPkg.haddockInterfaces = haddockInterfaces pkg,
1274 GhcPkg.haddockHTMLs = haddockHTMLs pkg,
1275 GhcPkg.exposedModules = map convertExposed (exposedModules pkg),
1276 GhcPkg.hiddenModules = hiddenModules pkg,
1277 GhcPkg.indefinite = indefinite pkg,
1278 GhcPkg.exposed = exposed pkg,
1279 GhcPkg.trusted = trusted pkg
1280 }
1281 where
1282 convertExposed (ExposedModule n reexport) = (n, reexport)
1283
1284 instance GhcPkg.BinaryStringRep ComponentId where
1285 fromStringRep = mkComponentId . fromStringRep
1286 toStringRep = toStringRep . display
1287
1288 instance GhcPkg.BinaryStringRep PackageName where
1289 fromStringRep = mkPackageName . fromStringRep
1290 toStringRep = toStringRep . display
1291
1292 instance GhcPkg.BinaryStringRep PackageIdentifier where
1293 fromStringRep = fromMaybe (error "BinaryStringRep PackageIdentifier")
1294 . simpleParse . fromStringRep
1295 toStringRep = toStringRep . display
1296
1297 instance GhcPkg.BinaryStringRep ModuleName where
1298 fromStringRep = ModuleName.fromString . fromStringRep
1299 toStringRep = toStringRep . display
1300
1301 instance GhcPkg.BinaryStringRep String where
1302 fromStringRep = fromUTF8 . BS.unpack
1303 toStringRep = BS.pack . toUTF8
1304
1305 instance GhcPkg.BinaryStringRep UnitId where
1306 fromStringRep = mkUnitId . fromStringRep
1307 toStringRep = toStringRep . display
1308
1309 instance GhcPkg.DbUnitIdModuleRep UnitId ComponentId OpenUnitId ModuleName OpenModule where
1310 fromDbModule (GhcPkg.DbModule uid mod_name) = OpenModule uid mod_name
1311 fromDbModule (GhcPkg.DbModuleVar mod_name) = OpenModuleVar mod_name
1312 toDbModule (OpenModule uid mod_name) = GhcPkg.DbModule uid mod_name
1313 toDbModule (OpenModuleVar mod_name) = GhcPkg.DbModuleVar mod_name
1314 fromDbUnitId (GhcPkg.DbUnitId cid insts) = IndefFullUnitId cid (Map.fromList insts)
1315 fromDbUnitId (GhcPkg.DbInstalledUnitId uid)
1316 = DefiniteUnitId (unsafeMkDefUnitId uid)
1317 toDbUnitId (IndefFullUnitId cid insts) = GhcPkg.DbUnitId cid (Map.toList insts)
1318 toDbUnitId (DefiniteUnitId def_uid)
1319 = GhcPkg.DbInstalledUnitId (unDefUnitId def_uid)
1320
1321 -- -----------------------------------------------------------------------------
1322 -- Exposing, Hiding, Trusting, Distrusting, Unregistering are all similar
1323
1324 exposePackage :: PackageArg -> Verbosity -> [Flag] -> Force -> IO ()
1325 exposePackage = modifyPackage (\p -> ModifyPackage p{exposed=True})
1326
1327 hidePackage :: PackageArg -> Verbosity -> [Flag] -> Force -> IO ()
1328 hidePackage = modifyPackage (\p -> ModifyPackage p{exposed=False})
1329
1330 trustPackage :: PackageArg -> Verbosity -> [Flag] -> Force -> IO ()
1331 trustPackage = modifyPackage (\p -> ModifyPackage p{trusted=True})
1332
1333 distrustPackage :: PackageArg -> Verbosity -> [Flag] -> Force -> IO ()
1334 distrustPackage = modifyPackage (\p -> ModifyPackage p{trusted=False})
1335
1336 unregisterPackage :: PackageArg -> Verbosity -> [Flag] -> Force -> IO ()
1337 unregisterPackage = modifyPackage RemovePackage
1338
1339 modifyPackage
1340 :: (InstalledPackageInfo -> DBOp)
1341 -> PackageArg
1342 -> Verbosity
1343 -> [Flag]
1344 -> Force
1345 -> IO ()
1346 modifyPackage fn pkgarg verbosity my_flags force = do
1347 (db_stack, GhcPkg.DbOpenReadWrite db, _flag_dbs) <-
1348 getPkgDatabases verbosity (GhcPkg.DbOpenReadWrite $ ContainsPkg pkgarg)
1349 True{-use user-} True{-use cache-} False{-expand vars-} my_flags
1350
1351 let db_name = location db
1352 pkgs = packages db
1353
1354 -- Get package respecting flags...
1355 ps = findPackage pkgarg pkgs
1356
1357 -- This shouldn't happen if getPkgDatabases picks the DB correctly.
1358 when (null ps) $ cannotFindPackage pkgarg $ Just db
1359
1360 let pks = map installedUnitId ps
1361
1362 cmds = [ fn pkg | pkg <- pkgs, installedUnitId pkg `elem` pks ]
1363 new_db = updateInternalDB db cmds
1364 new_db_ro = new_db { packageDbLock = GhcPkg.DbOpenReadOnly }
1365
1366 -- ...but do consistency checks with regards to the full stack
1367 old_broken = brokenPackages (allPackagesInStack db_stack)
1368 rest_of_stack = filter ((/= db_name) . location) db_stack
1369 new_stack = new_db_ro : rest_of_stack
1370 new_broken = brokenPackages (allPackagesInStack new_stack)
1371 newly_broken = filter ((`notElem` map installedUnitId old_broken)
1372 . installedUnitId) new_broken
1373 --
1374 let displayQualPkgId pkg
1375 | [_] <- filter ((== pkgid) . sourcePackageId)
1376 (allPackagesInStack db_stack)
1377 = display pkgid
1378 | otherwise = display pkgid ++ "@" ++ display (installedUnitId pkg)
1379 where pkgid = sourcePackageId pkg
1380 when (not (null newly_broken)) $
1381 dieOrForceAll force ("unregistering would break the following packages: "
1382 ++ unwords (map displayQualPkgId newly_broken))
1383
1384 changeDB verbosity cmds db
1385
1386 recache :: Verbosity -> [Flag] -> IO ()
1387 recache verbosity my_flags = do
1388 (_db_stack, GhcPkg.DbOpenReadWrite db_to_operate_on, _flag_dbs) <-
1389 getPkgDatabases verbosity (GhcPkg.DbOpenReadWrite TopOne)
1390 True{-use user-} False{-no cache-} False{-expand vars-} my_flags
1391 changeDB verbosity [] db_to_operate_on
1392
1393 -- -----------------------------------------------------------------------------
1394 -- Listing packages
1395
1396 listPackages :: Verbosity -> [Flag] -> Maybe PackageArg
1397 -> Maybe (String->Bool)
1398 -> IO ()
1399 listPackages verbosity my_flags mPackageName mModuleName = do
1400 let simple_output = FlagSimpleOutput `elem` my_flags
1401 (db_stack, GhcPkg.DbOpenReadOnly, flag_db_stack) <-
1402 getPkgDatabases verbosity GhcPkg.DbOpenReadOnly
1403 False{-use user-} True{-use cache-} False{-expand vars-} my_flags
1404
1405 let db_stack_filtered -- if a package is given, filter out all other packages
1406 | Just this <- mPackageName =
1407 [ db{ packages = filter (this `matchesPkg`) (packages db) }
1408 | db <- flag_db_stack ]
1409 | Just match <- mModuleName = -- packages which expose mModuleName
1410 [ db{ packages = filter (match `exposedInPkg`) (packages db) }
1411 | db <- flag_db_stack ]
1412 | otherwise = flag_db_stack
1413
1414 db_stack_sorted
1415 = [ db{ packages = sort_pkgs (packages db) }
1416 | db <- db_stack_filtered ]
1417 where sort_pkgs = sortBy cmpPkgIds
1418 cmpPkgIds pkg1 pkg2 =
1419 case pkgName p1 `compare` pkgName p2 of
1420 LT -> LT
1421 GT -> GT
1422 EQ -> case pkgVersion p1 `compare` pkgVersion p2 of
1423 LT -> LT
1424 GT -> GT
1425 EQ -> installedUnitId pkg1 `compare` installedUnitId pkg2
1426 where (p1,p2) = (sourcePackageId pkg1, sourcePackageId pkg2)
1427
1428 stack = reverse db_stack_sorted
1429
1430 match `exposedInPkg` pkg = any match (map display $ exposedModules pkg)
1431
1432 pkg_map = allPackagesInStack db_stack
1433 broken = map installedUnitId (brokenPackages pkg_map)
1434
1435 show_normal PackageDB{ location = db_name, packages = pkg_confs } =
1436 do hPutStrLn stdout db_name
1437 if null pkg_confs
1438 then hPutStrLn stdout " (no packages)"
1439 else hPutStrLn stdout $ unlines (map (" " ++) (map pp_pkg pkg_confs))
1440 where
1441 pp_pkg p
1442 | installedUnitId p `elem` broken = printf "{%s}" doc
1443 | exposed p = doc
1444 | otherwise = printf "(%s)" doc
1445 where doc | verbosity >= Verbose = printf "%s (%s)" pkg (display (installedUnitId p))
1446 | otherwise = pkg
1447 where
1448 pkg = display (sourcePackageId p)
1449
1450 show_simple = simplePackageList my_flags . allPackagesInStack
1451
1452 when (not (null broken) && not simple_output && verbosity /= Silent) $ do
1453 prog <- getProgramName
1454 warn ("WARNING: there are broken packages. Run '" ++ prog ++ " check' for more details.")
1455
1456 if simple_output then show_simple stack else do
1457
1458 #ifndef WITH_TERMINFO
1459 mapM_ show_normal stack
1460 #else
1461 let
1462 show_colour withF db@PackageDB{ packages = pkg_confs } =
1463 if null pkg_confs
1464 then termText (location db) <#> termText "\n (no packages)\n"
1465 else
1466 mconcat $ map (<#> termText "\n") $
1467 (termText (location db)
1468 : map (termText " " <#>) (map pp_pkg pkg_confs))
1469 where
1470 pp_pkg p
1471 | installedUnitId p `elem` broken = withF Red doc
1472 | exposed p = doc
1473 | otherwise = withF Blue doc
1474 where doc | verbosity >= Verbose
1475 = termText (printf "%s (%s)" pkg (display (installedUnitId p)))
1476 | otherwise
1477 = termText pkg
1478 where
1479 pkg = display (sourcePackageId p)
1480
1481 is_tty <- hIsTerminalDevice stdout
1482 if not is_tty
1483 then mapM_ show_normal stack
1484 else do tty <- Terminfo.setupTermFromEnv
1485 case Terminfo.getCapability tty withForegroundColor of
1486 Nothing -> mapM_ show_normal stack
1487 Just w -> runTermOutput tty $ mconcat $
1488 map (show_colour w) stack
1489 #endif
1490
1491 simplePackageList :: [Flag] -> [InstalledPackageInfo] -> IO ()
1492 simplePackageList my_flags pkgs = do
1493 let showPkg = if FlagNamesOnly `elem` my_flags then display . pkgName
1494 else display
1495 strs = map showPkg $ map sourcePackageId pkgs
1496 when (not (null pkgs)) $
1497 hPutStrLn stdout $ concat $ intersperse " " strs
1498
1499 showPackageDot :: Verbosity -> [Flag] -> IO ()
1500 showPackageDot verbosity myflags = do
1501 (_, GhcPkg.DbOpenReadOnly, flag_db_stack) <-
1502 getPkgDatabases verbosity GhcPkg.DbOpenReadOnly
1503 False{-use user-} True{-use cache-} False{-expand vars-} myflags
1504
1505 let all_pkgs = allPackagesInStack flag_db_stack
1506 ipix = PackageIndex.fromList all_pkgs
1507
1508 putStrLn "digraph {"
1509 let quote s = '"':s ++ "\""
1510 mapM_ putStrLn [ quote from ++ " -> " ++ quote to
1511 | p <- all_pkgs,
1512 let from = display (sourcePackageId p),
1513 key <- depends p,
1514 Just dep <- [PackageIndex.lookupUnitId ipix key],
1515 let to = display (sourcePackageId dep)
1516 ]
1517 putStrLn "}"
1518
1519 -- -----------------------------------------------------------------------------
1520 -- Prints the highest (hidden or exposed) version of a package
1521
1522 -- ToDo: This is no longer well-defined with unit ids, because the
1523 -- dependencies may be varying versions
1524 latestPackage :: Verbosity -> [Flag] -> GlobPackageIdentifier -> IO ()
1525 latestPackage verbosity my_flags pkgid = do
1526 (_, GhcPkg.DbOpenReadOnly, flag_db_stack) <-
1527 getPkgDatabases verbosity GhcPkg.DbOpenReadOnly
1528 False{-use user-} True{-use cache-} False{-expand vars-} my_flags
1529
1530 ps <- findPackages flag_db_stack (Id pkgid)
1531 case ps of
1532 [] -> die "no matches"
1533 _ -> show_pkg . maximum . map sourcePackageId $ ps
1534 where
1535 show_pkg pid = hPutStrLn stdout (display pid)
1536
1537 -- -----------------------------------------------------------------------------
1538 -- Describe
1539
1540 describePackage :: Verbosity -> [Flag] -> PackageArg -> Bool -> IO ()
1541 describePackage verbosity my_flags pkgarg expand_pkgroot = do
1542 (_, GhcPkg.DbOpenReadOnly, flag_db_stack) <-
1543 getPkgDatabases verbosity GhcPkg.DbOpenReadOnly
1544 False{-use user-} True{-use cache-} expand_pkgroot my_flags
1545 dbs <- findPackagesByDB flag_db_stack pkgarg
1546 doDump expand_pkgroot [ (pkg, locationAbsolute db)
1547 | (db, pkgs) <- dbs, pkg <- pkgs ]
1548
1549 dumpPackages :: Verbosity -> [Flag] -> Bool -> IO ()
1550 dumpPackages verbosity my_flags expand_pkgroot = do
1551 (_, GhcPkg.DbOpenReadOnly, flag_db_stack) <-
1552 getPkgDatabases verbosity GhcPkg.DbOpenReadOnly
1553 False{-use user-} True{-use cache-} expand_pkgroot my_flags
1554 doDump expand_pkgroot [ (pkg, locationAbsolute db)
1555 | db <- flag_db_stack, pkg <- packages db ]
1556
1557 doDump :: Bool -> [(InstalledPackageInfo, FilePath)] -> IO ()
1558 doDump expand_pkgroot pkgs = do
1559 -- fix the encoding to UTF-8, since this is an interchange format
1560 hSetEncoding stdout utf8
1561 putStrLn $
1562 intercalate "---\n"
1563 [ if expand_pkgroot
1564 then showInstalledPackageInfo pkg
1565 else showInstalledPackageInfo pkg ++ pkgrootField
1566 | (pkg, pkgloc) <- pkgs
1567 , let pkgroot = takeDirectory pkgloc
1568 pkgrootField = "pkgroot: " ++ show pkgroot ++ "\n" ]
1569
1570 -- PackageId is can have globVersion for the version
1571 findPackages :: PackageDBStack -> PackageArg -> IO [InstalledPackageInfo]
1572 findPackages db_stack pkgarg
1573 = fmap (concatMap snd) $ findPackagesByDB db_stack pkgarg
1574
1575 findPackage :: PackageArg -> [InstalledPackageInfo] -> [InstalledPackageInfo]
1576 findPackage pkgarg pkgs = filter (pkgarg `matchesPkg`) pkgs
1577
1578 findPackagesByDB :: PackageDBStack -> PackageArg
1579 -> IO [(PackageDB 'GhcPkg.DbReadOnly, [InstalledPackageInfo])]
1580 findPackagesByDB db_stack pkgarg
1581 = case [ (db, matched)
1582 | db <- db_stack,
1583 let matched = findPackage pkgarg $ packages db,
1584 not (null matched) ] of
1585 [] -> cannotFindPackage pkgarg Nothing
1586 ps -> return ps
1587
1588 cannotFindPackage :: PackageArg -> Maybe (PackageDB mode) -> IO a
1589 cannotFindPackage pkgarg mdb = die $ "cannot find package " ++ pkg_msg pkgarg
1590 ++ maybe "" (\db -> " in " ++ location db) mdb
1591 where
1592 pkg_msg (Id pkgid) = displayGlobPkgId pkgid
1593 pkg_msg (IUId ipid) = display ipid
1594 pkg_msg (Substring pkgpat _) = "matching " ++ pkgpat
1595
1596 matches :: GlobPackageIdentifier -> PackageIdentifier -> Bool
1597 GlobPackageIdentifier pn `matches` pid'
1598 = (pn == pkgName pid')
1599 ExactPackageIdentifier pid `matches` pid'
1600 = pkgName pid == pkgName pid' &&
1601 (pkgVersion pid == pkgVersion pid' || pkgVersion pid == nullVersion)
1602
1603 matchesPkg :: PackageArg -> InstalledPackageInfo -> Bool
1604 (Id pid) `matchesPkg` pkg = pid `matches` sourcePackageId pkg
1605 (IUId ipid) `matchesPkg` pkg = ipid == installedUnitId pkg
1606 (Substring _ m) `matchesPkg` pkg = m (display (sourcePackageId pkg))
1607
1608 -- -----------------------------------------------------------------------------
1609 -- Field
1610
1611 describeField :: Verbosity -> [Flag] -> PackageArg -> [String] -> Bool -> IO ()
1612 describeField verbosity my_flags pkgarg fields expand_pkgroot = do
1613 (_, GhcPkg.DbOpenReadOnly, flag_db_stack) <-
1614 getPkgDatabases verbosity GhcPkg.DbOpenReadOnly
1615 False{-use user-} True{-use cache-} expand_pkgroot my_flags
1616 fns <- mapM toField fields
1617 ps <- findPackages flag_db_stack pkgarg
1618 mapM_ (selectFields fns) ps
1619 where showFun = if FlagSimpleOutput `elem` my_flags
1620 then showSimpleInstalledPackageInfoField
1621 else showInstalledPackageInfoField
1622 toField f = case showFun f of
1623 Nothing -> die ("unknown field: " ++ f)
1624 Just fn -> return fn
1625 selectFields fns pinfo = mapM_ (\fn->putStrLn (fn pinfo)) fns
1626
1627
1628 -- -----------------------------------------------------------------------------
1629 -- Check: Check consistency of installed packages
1630
1631 checkConsistency :: Verbosity -> [Flag] -> IO ()
1632 checkConsistency verbosity my_flags = do
1633 (db_stack, GhcPkg.DbOpenReadOnly, _) <-
1634 getPkgDatabases verbosity GhcPkg.DbOpenReadOnly
1635 True{-use user-} True{-use cache-} True{-expand vars-} my_flags
1636 -- although check is not a modify command, we do need to use the user
1637 -- db, because we may need it to verify package deps.
1638
1639 let simple_output = FlagSimpleOutput `elem` my_flags
1640
1641 let pkgs = allPackagesInStack db_stack
1642
1643 checkPackage p = do
1644 (_,es,ws) <- runValidate $ checkPackageConfig p verbosity db_stack
1645 True True
1646 if null es
1647 then do when (not simple_output) $ do
1648 _ <- reportValidateErrors verbosity [] ws "" Nothing
1649 return ()
1650 return []
1651 else do
1652 when (not simple_output) $ do
1653 reportError ("There are problems in package " ++ display (sourcePackageId p) ++ ":")
1654 _ <- reportValidateErrors verbosity es ws " " Nothing
1655 return ()
1656 return [p]
1657
1658 broken_pkgs <- concat `fmap` mapM checkPackage pkgs
1659
1660 let filterOut pkgs1 pkgs2 = filter not_in pkgs2
1661 where not_in p = sourcePackageId p `notElem` all_ps
1662 all_ps = map sourcePackageId pkgs1
1663
1664 let not_broken_pkgs = filterOut broken_pkgs pkgs
1665 (_, trans_broken_pkgs) = closure [] not_broken_pkgs
1666 all_broken_pkgs = broken_pkgs ++ trans_broken_pkgs
1667
1668 when (not (null all_broken_pkgs)) $ do
1669 if simple_output
1670 then simplePackageList my_flags all_broken_pkgs
1671 else do
1672 reportError ("\nThe following packages are broken, either because they have a problem\n"++
1673 "listed above, or because they depend on a broken package.")
1674 mapM_ (hPutStrLn stderr . display . sourcePackageId) all_broken_pkgs
1675
1676 when (not (null all_broken_pkgs)) $ exitWith (ExitFailure 1)
1677
1678
1679 closure :: [InstalledPackageInfo] -> [InstalledPackageInfo]
1680 -> ([InstalledPackageInfo], [InstalledPackageInfo])
1681 closure pkgs db_stack = go pkgs db_stack
1682 where
1683 go avail not_avail =
1684 case partition (depsAvailable avail) not_avail of
1685 ([], not_avail') -> (avail, not_avail')
1686 (new_avail, not_avail') -> go (new_avail ++ avail) not_avail'
1687
1688 depsAvailable :: [InstalledPackageInfo] -> InstalledPackageInfo
1689 -> Bool
1690 depsAvailable pkgs_ok pkg = null dangling
1691 where dangling = filter (`notElem` pids) (depends pkg)
1692 pids = map installedUnitId pkgs_ok
1693
1694 -- we want mutually recursive groups of package to show up
1695 -- as broken. (#1750)
1696
1697 brokenPackages :: [InstalledPackageInfo] -> [InstalledPackageInfo]
1698 brokenPackages pkgs = snd (closure [] pkgs)
1699
1700 -----------------------------------------------------------------------------
1701 -- Sanity-check a new package config, and automatically build GHCi libs
1702 -- if requested.
1703
1704 type ValidateError = (Force,String)
1705 type ValidateWarning = String
1706
1707 newtype Validate a = V { runValidate :: IO (a, [ValidateError],[ValidateWarning]) }
1708
1709 instance Functor Validate where
1710 fmap = liftM
1711
1712 instance Applicative Validate where
1713 pure a = V $ pure (a, [], [])
1714 (<*>) = ap
1715
1716 instance Monad Validate where
1717 m >>= k = V $ do
1718 (a, es, ws) <- runValidate m
1719 (b, es', ws') <- runValidate (k a)
1720 return (b,es++es',ws++ws')
1721
1722 verror :: Force -> String -> Validate ()
1723 verror f s = V (return ((),[(f,s)],[]))
1724
1725 vwarn :: String -> Validate ()
1726 vwarn s = V (return ((),[],["Warning: " ++ s]))
1727
1728 liftIO :: IO a -> Validate a
1729 liftIO k = V (k >>= \a -> return (a,[],[]))
1730
1731 -- returns False if we should die
1732 reportValidateErrors :: Verbosity -> [ValidateError] -> [ValidateWarning]
1733 -> String -> Maybe Force -> IO Bool
1734 reportValidateErrors verbosity es ws prefix mb_force = do
1735 mapM_ (warn . (prefix++)) ws
1736 oks <- mapM report es
1737 return (and oks)
1738 where
1739 report (f,s)
1740 | Just force <- mb_force
1741 = if (force >= f)
1742 then do when (verbosity >= Normal) $
1743 reportError (prefix ++ s ++ " (ignoring)")
1744 return True
1745 else if f < CannotForce
1746 then do reportError (prefix ++ s ++ " (use --force to override)")
1747 return False
1748 else do reportError err
1749 return False
1750 | otherwise = do reportError err
1751 return False
1752 where
1753 err = prefix ++ s
1754
1755 validatePackageConfig :: InstalledPackageInfo
1756 -> Verbosity
1757 -> PackageDBStack
1758 -> Bool -- multi_instance
1759 -> Bool -- update, or check
1760 -> Force
1761 -> IO ()
1762 validatePackageConfig pkg verbosity db_stack
1763 multi_instance update force = do
1764 (_,es,ws) <- runValidate $
1765 checkPackageConfig pkg verbosity db_stack
1766 multi_instance update
1767 ok <- reportValidateErrors verbosity es ws
1768 (display (sourcePackageId pkg) ++ ": ") (Just force)
1769 when (not ok) $ exitWith (ExitFailure 1)
1770
1771 checkPackageConfig :: InstalledPackageInfo
1772 -> Verbosity
1773 -> PackageDBStack
1774 -> Bool -- multi_instance
1775 -> Bool -- update, or check
1776 -> Validate ()
1777 checkPackageConfig pkg verbosity db_stack
1778 multi_instance update = do
1779 checkPackageId pkg
1780 checkUnitId pkg db_stack update
1781 checkDuplicates db_stack pkg multi_instance update
1782 mapM_ (checkDep db_stack) (depends pkg)
1783 checkDuplicateDepends (depends pkg)
1784 mapM_ (checkDir False "import-dirs") (importDirs pkg)
1785 mapM_ (checkDir True "library-dirs") (libraryDirs pkg)
1786 mapM_ (checkDir True "dynamic-library-dirs") (libraryDynDirs pkg)
1787 mapM_ (checkDir True "include-dirs") (includeDirs pkg)
1788 mapM_ (checkDir True "framework-dirs") (frameworkDirs pkg)
1789 mapM_ (checkFile True "haddock-interfaces") (haddockInterfaces pkg)
1790 mapM_ (checkDirURL True "haddock-html") (haddockHTMLs pkg)
1791 checkDuplicateModules pkg
1792 checkExposedModules db_stack pkg
1793 checkOtherModules pkg
1794 let has_code = Set.null (openModuleSubstFreeHoles (Map.fromList (instantiatedWith pkg)))
1795 when has_code $ mapM_ (checkHSLib verbosity (libraryDirs pkg ++ libraryDynDirs pkg)) (hsLibraries pkg)
1796 -- ToDo: check these somehow?
1797 -- extra_libraries :: [String],
1798 -- c_includes :: [String],
1799
1800 -- When the package name and version are put together, sometimes we can
1801 -- end up with a package id that cannot be parsed. This will lead to
1802 -- difficulties when the user wants to refer to the package later, so
1803 -- we check that the package id can be parsed properly here.
1804 checkPackageId :: InstalledPackageInfo -> Validate ()
1805 checkPackageId ipi =
1806 let str = display (sourcePackageId ipi) in
1807 case [ x :: PackageIdentifier | (x,ys) <- readP_to_S parse str, all isSpace ys ] of
1808 [_] -> return ()
1809 [] -> verror CannotForce ("invalid package identifier: " ++ str)
1810 _ -> verror CannotForce ("ambiguous package identifier: " ++ str)
1811
1812 checkUnitId :: InstalledPackageInfo -> PackageDBStack -> Bool
1813 -> Validate ()
1814 checkUnitId ipi db_stack update = do
1815 let uid = installedUnitId ipi
1816 when (null (display uid)) $ verror CannotForce "missing id field"
1817 when (display uid /= compatPackageKey ipi) $
1818 verror CannotForce $ "installed package info from too old version of Cabal "
1819 ++ "(key field does not match id field)"
1820 let dups = [ p | p <- allPackagesInStack db_stack,
1821 installedUnitId p == uid ]
1822 when (not update && not (null dups)) $
1823 verror CannotForce $
1824 "package(s) with this id already exist: " ++
1825 unwords (map (display.installedUnitId) dups)
1826
1827 checkDuplicates :: PackageDBStack -> InstalledPackageInfo
1828 -> Bool -> Bool-> Validate ()
1829 checkDuplicates db_stack pkg multi_instance update = do
1830 let
1831 pkgid = sourcePackageId pkg
1832 pkgs = packages (head db_stack)
1833 --
1834 -- Check whether this package id already exists in this DB
1835 --
1836 when (not update && not multi_instance
1837 && (pkgid `elem` map sourcePackageId pkgs)) $
1838 verror CannotForce $
1839 "package " ++ display pkgid ++ " is already installed"
1840
1841 let
1842 uncasep = map toLower . display
1843 dups = filter ((== uncasep pkgid) . uncasep) (map sourcePackageId pkgs)
1844
1845 when (not update && not multi_instance
1846 && not (null dups)) $ verror ForceAll $
1847 "Package names may be treated case-insensitively in the future.\n"++
1848 "Package " ++ display pkgid ++
1849 " overlaps with: " ++ unwords (map display dups)
1850
1851 checkDir, checkFile, checkDirURL :: Bool -> String -> FilePath -> Validate ()
1852 checkDir = checkPath False True
1853 checkFile = checkPath False False
1854 checkDirURL = checkPath True True
1855
1856 checkPath :: Bool -> Bool -> Bool -> String -> FilePath -> Validate ()
1857 checkPath url_ok is_dir warn_only thisfield d
1858 | url_ok && ("http://" `isPrefixOf` d
1859 || "https://" `isPrefixOf` d) = return ()
1860
1861 | url_ok
1862 , Just d' <- stripPrefix "file://" d
1863 = checkPath False is_dir warn_only thisfield d'
1864
1865 -- Note: we don't check for $topdir/${pkgroot} here. We rely on these
1866 -- variables having been expanded already, see mungePackagePaths.
1867
1868 | isRelative d = verror ForceFiles $
1869 thisfield ++ ": " ++ d ++ " is a relative path which "
1870 ++ "makes no sense (as there is nothing for it to be "
1871 ++ "relative to). You can make paths relative to the "
1872 ++ "package database itself by using ${pkgroot}."
1873 -- relative paths don't make any sense; #4134
1874 | otherwise = do
1875 there <- liftIO $ if is_dir then doesDirectoryExist d else doesFileExist d
1876 when (not there) $
1877 let msg = thisfield ++ ": " ++ d ++ " doesn't exist or isn't a "
1878 ++ if is_dir then "directory" else "file"
1879 in
1880 if warn_only
1881 then vwarn msg
1882 else verror ForceFiles msg
1883
1884 checkDep :: PackageDBStack -> UnitId -> Validate ()
1885 checkDep db_stack pkgid
1886 | pkgid `elem` pkgids = return ()
1887 | otherwise = verror ForceAll ("dependency \"" ++ display pkgid
1888 ++ "\" doesn't exist")
1889 where
1890 all_pkgs = allPackagesInStack db_stack
1891 pkgids = map installedUnitId all_pkgs
1892
1893 checkDuplicateDepends :: [UnitId] -> Validate ()
1894 checkDuplicateDepends deps
1895 | null dups = return ()
1896 | otherwise = verror ForceAll ("package has duplicate dependencies: " ++
1897 unwords (map display dups))
1898 where
1899 dups = [ p | (p:_:_) <- group (sort deps) ]
1900
1901 checkHSLib :: Verbosity -> [String] -> String -> Validate ()
1902 checkHSLib _verbosity dirs lib = do
1903 let filenames = ["lib" ++ lib ++ ".a",
1904 "lib" ++ lib ++ ".p_a",
1905 "lib" ++ lib ++ "-ghc" ++ Version.version ++ ".so",
1906 "lib" ++ lib ++ "-ghc" ++ Version.version ++ ".dylib",
1907 lib ++ "-ghc" ++ Version.version ++ ".dll"]
1908 b <- liftIO $ doesFileExistOnPath filenames dirs
1909 when (not b) $
1910 verror ForceFiles ("cannot find any of " ++ show filenames ++
1911 " on library path")
1912
1913 doesFileExistOnPath :: [FilePath] -> [FilePath] -> IO Bool
1914 doesFileExistOnPath filenames paths = anyM doesFileExist fullFilenames
1915 where fullFilenames = [ path </> filename
1916 | filename <- filenames
1917 , path <- paths ]
1918
1919 -- | Perform validation checks (module file existence checks) on the
1920 -- @hidden-modules@ field.
1921 checkOtherModules :: InstalledPackageInfo -> Validate ()
1922 checkOtherModules pkg = mapM_ (checkModuleFile pkg) (hiddenModules pkg)
1923
1924 -- | Perform validation checks (module file existence checks and module
1925 -- reexport checks) on the @exposed-modules@ field.
1926 checkExposedModules :: PackageDBStack -> InstalledPackageInfo -> Validate ()
1927 checkExposedModules db_stack pkg =
1928 mapM_ checkExposedModule (exposedModules pkg)
1929 where
1930 checkExposedModule (ExposedModule modl reexport) = do
1931 let checkOriginal = checkModuleFile pkg modl
1932 checkReexport = checkModule "module reexport" db_stack pkg
1933 maybe checkOriginal checkReexport reexport
1934
1935 -- | Validates the existence of an appropriate @hi@ file associated with
1936 -- a module. Used for both @hidden-modules@ and @exposed-modules@ which
1937 -- are not reexports.
1938 checkModuleFile :: InstalledPackageInfo -> ModuleName -> Validate ()
1939 checkModuleFile pkg modl =
1940 -- there's no interface file for GHC.Prim
1941 unless (modl == ModuleName.fromString "GHC.Prim") $ do
1942 let files = [ ModuleName.toFilePath modl <.> extension
1943 | extension <- ["hi", "p_hi", "dyn_hi" ] ]
1944 b <- liftIO $ doesFileExistOnPath files (importDirs pkg)
1945 when (not b) $
1946 verror ForceFiles ("cannot find any of " ++ show files)
1947
1948 -- | Validates that @exposed-modules@ and @hidden-modules@ do not have duplicate
1949 -- entries.
1950 -- ToDo: this needs updating for signatures: signatures can validly show up
1951 -- multiple times in the @exposed-modules@ list as long as their backing
1952 -- implementations agree.
1953 checkDuplicateModules :: InstalledPackageInfo -> Validate ()
1954 checkDuplicateModules pkg
1955 | null dups = return ()
1956 | otherwise = verror ForceAll ("package has duplicate modules: " ++
1957 unwords (map display dups))
1958 where
1959 dups = [ m | (m:_:_) <- group (sort mods) ]
1960 mods = map exposedName (exposedModules pkg) ++ hiddenModules pkg
1961
1962 -- | Validates an original module entry, either the origin of a module reexport
1963 -- or the backing implementation of a signature, by checking that it exists,
1964 -- really is an original definition, and is accessible from the dependencies of
1965 -- the package.
1966 -- ToDo: If the original module in question is a backing signature
1967 -- implementation, then we should also check that the original module in
1968 -- question is NOT a signature (however, if it is a reexport, then it's fine
1969 -- for the original module to be a signature.)
1970 checkModule :: String
1971 -> PackageDBStack
1972 -> InstalledPackageInfo
1973 -> OpenModule
1974 -> Validate ()
1975 checkModule _ _ _ (OpenModuleVar _) = error "Impermissible reexport"
1976 checkModule field_name db_stack pkg
1977 (OpenModule (DefiniteUnitId def_uid) definingModule) =
1978 let definingPkgId = unDefUnitId def_uid
1979 mpkg = if definingPkgId == installedUnitId pkg
1980 then Just pkg
1981 else PackageIndex.lookupUnitId ipix definingPkgId
1982 in case mpkg of
1983 Nothing
1984 -> verror ForceAll (field_name ++ " refers to a non-existent " ++
1985 "defining package: " ++
1986 display definingPkgId)
1987
1988 Just definingPkg
1989 | not (isIndirectDependency definingPkgId)
1990 -> verror ForceAll (field_name ++ " refers to a defining " ++
1991 "package that is not a direct (or indirect) " ++
1992 "dependency of this package: " ++
1993 display definingPkgId)
1994
1995 | otherwise
1996 -> case find ((==definingModule).exposedName)
1997 (exposedModules definingPkg) of
1998 Nothing ->
1999 verror ForceAll (field_name ++ " refers to a module " ++
2000 display definingModule ++ " " ++
2001 "that is not exposed in the " ++
2002 "defining package " ++ display definingPkgId)
2003 Just (ExposedModule {exposedReexport = Just _} ) ->
2004 verror ForceAll (field_name ++ " refers to a module " ++
2005 display definingModule ++ " " ++
2006 "that is reexported but not defined in the " ++
2007 "defining package " ++ display definingPkgId)
2008 _ -> return ()
2009 where
2010 all_pkgs = allPackagesInStack db_stack
2011 ipix = PackageIndex.fromList all_pkgs
2012
2013 isIndirectDependency pkgid = fromMaybe False $ do
2014 thispkg <- graphVertex (installedUnitId pkg)
2015 otherpkg <- graphVertex pkgid
2016 return (Graph.path depgraph thispkg otherpkg)
2017 (depgraph, _, graphVertex) =
2018 PackageIndex.dependencyGraph (PackageIndex.insert pkg ipix)
2019
2020 checkModule _ _ _ (OpenModule (IndefFullUnitId _ _) _) =
2021 -- TODO: add some checks here
2022 return ()
2023
2024
2025 -- ---------------------------------------------------------------------------
2026 -- expanding environment variables in the package configuration
2027
2028 expandEnvVars :: String -> Force -> IO String
2029 expandEnvVars str0 force = go str0 ""
2030 where
2031 go "" acc = return $! reverse acc
2032 go ('$':'{':str) acc | (var, '}':rest) <- break close str
2033 = do value <- lookupEnvVar var
2034 go rest (reverse value ++ acc)
2035 where close c = c == '}' || c == '\n' -- don't span newlines
2036 go (c:str) acc
2037 = go str (c:acc)
2038
2039 lookupEnvVar :: String -> IO String
2040 lookupEnvVar "pkgroot" = return "${pkgroot}" -- these two are special,
2041 lookupEnvVar "pkgrooturl" = return "${pkgrooturl}" -- we don't expand them
2042 lookupEnvVar nm =
2043 catchIO (System.Environment.getEnv nm)
2044 (\ _ -> do dieOrForceAll force ("Unable to expand variable " ++
2045 show nm)
2046 return "")
2047
2048 -----------------------------------------------------------------------------
2049
2050 getProgramName :: IO String
2051 getProgramName = liftM (`withoutSuffix` ".bin") getProgName
2052 where str `withoutSuffix` suff
2053 | suff `isSuffixOf` str = take (length str - length suff) str
2054 | otherwise = str
2055
2056 bye :: String -> IO a
2057 bye s = putStr s >> exitWith ExitSuccess
2058
2059 die :: String -> IO a
2060 die = dieWith 1
2061
2062 dieWith :: Int -> String -> IO a
2063 dieWith ec s = do
2064 prog <- getProgramName
2065 reportError (prog ++ ": " ++ s)
2066 exitWith (ExitFailure ec)
2067
2068 dieOrForceAll :: Force -> String -> IO ()
2069 dieOrForceAll ForceAll s = ignoreError s
2070 dieOrForceAll _other s = dieForcible s
2071
2072 warn :: String -> IO ()
2073 warn = reportError
2074
2075 -- send info messages to stdout
2076 infoLn :: String -> IO ()
2077 infoLn = putStrLn
2078
2079 info :: String -> IO ()
2080 info = putStr
2081
2082 ignoreError :: String -> IO ()
2083 ignoreError s = reportError (s ++ " (ignoring)")
2084
2085 reportError :: String -> IO ()
2086 reportError s = do hFlush stdout; hPutStrLn stderr s
2087
2088 dieForcible :: String -> IO ()
2089 dieForcible s = die (s ++ " (use --force to override)")
2090
2091 -----------------------------------------
2092 -- Cut and pasted from ghc/compiler/main/SysTools
2093
2094 #if defined(mingw32_HOST_OS)
2095 subst :: Char -> Char -> String -> String
2096 subst a b ls = map (\ x -> if x == a then b else x) ls
2097
2098 unDosifyPath :: FilePath -> FilePath
2099 unDosifyPath xs = subst '\\' '/' xs
2100
2101 getLibDir :: IO (Maybe String)
2102 getLibDir = do base <- getExecDir "/ghc-pkg.exe"
2103 case base of
2104 Nothing -> return Nothing
2105 Just base' -> do
2106 libdir <- canonicalizePath $ base' </> "../lib"
2107 exists <- doesDirectoryExist libdir
2108 if exists
2109 then return $ Just libdir
2110 else return Nothing
2111
2112 -- (getExecDir cmd) returns the directory in which the current
2113 -- executable, which should be called 'cmd', is running
2114 -- So if the full path is /a/b/c/d/e, and you pass "d/e" as cmd,
2115 -- you'll get "/a/b/c" back as the result
2116 getExecDir :: String -> IO (Maybe String)
2117 getExecDir cmd =
2118 getExecPath >>= maybe (return Nothing) removeCmdSuffix
2119 where initN n = reverse . drop n . reverse
2120 removeCmdSuffix = return . Just . initN (length cmd) . unDosifyPath
2121
2122 getExecPath :: IO (Maybe String)
2123 getExecPath = try_size 2048 -- plenty, PATH_MAX is 512 under Win32.
2124 where
2125 try_size size = allocaArray (fromIntegral size) $ \buf -> do
2126 ret <- c_GetModuleFileName nullPtr buf size
2127 case ret of
2128 0 -> return Nothing
2129 _ | ret < size -> fmap Just $ peekCWString buf
2130 | otherwise -> try_size (size * 2)
2131
2132 foreign import WINDOWS_CCONV unsafe "windows.h GetModuleFileNameW"
2133 c_GetModuleFileName :: Ptr () -> CWString -> Word32 -> IO Word32
2134 #else
2135 getLibDir :: IO (Maybe String)
2136 getLibDir = return Nothing
2137 #endif
2138
2139 -----------------------------------------
2140 -- Adapted from ghc/compiler/utils/Panic
2141
2142 installSignalHandlers :: IO ()
2143 installSignalHandlers = do
2144 threadid <- myThreadId
2145 let
2146 interrupt = Exception.throwTo threadid
2147 (Exception.ErrorCall "interrupted")
2148 --
2149 #if !defined(mingw32_HOST_OS)
2150 _ <- installHandler sigQUIT (Catch interrupt) Nothing
2151 _ <- installHandler sigINT (Catch interrupt) Nothing
2152 return ()
2153 #else
2154 -- GHC 6.3+ has support for console events on Windows
2155 -- NOTE: running GHCi under a bash shell for some reason requires
2156 -- you to press Ctrl-Break rather than Ctrl-C to provoke
2157 -- an interrupt. Ctrl-C is getting blocked somewhere, I don't know
2158 -- why --SDM 17/12/2004
2159 let sig_handler ControlC = interrupt
2160 sig_handler Break = interrupt
2161 sig_handler _ = return ()
2162
2163 _ <- installHandler (Catch sig_handler)
2164 return ()
2165 #endif
2166
2167 catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a
2168 catchIO = Exception.catch
2169
2170 tryIO :: IO a -> IO (Either Exception.IOException a)
2171 tryIO = Exception.try
2172
2173 -- removeFileSave doesn't throw an exceptions, if the file is already deleted
2174 removeFileSafe :: FilePath -> IO ()
2175 removeFileSafe fn =
2176 removeFile fn `catchIO` \ e ->
2177 when (not $ isDoesNotExistError e) $ ioError e
2178
2179 -- | Turn a path relative to the current directory into a (normalised)
2180 -- absolute path.
2181 absolutePath :: FilePath -> IO FilePath
2182 absolutePath path = return . normalise . (</> path) =<< getCurrentDirectory
2183
2184
2185 {- Note [writeAtomic leaky abstraction]
2186 GhcPkg.writePackageDb calls writeAtomic, which first writes to a temp file,
2187 and then moves the tempfile to its final destination. This all happens in the
2188 same directory (package.conf.d).
2189 Moving a file doesn't change its modification time, but it *does* change the
2190 modification time of the directory it is placed in. Since we compare the
2191 modification time of the cache file to that of the directory it is in to
2192 decide whether the cache is out-of-date, it will be instantly out-of-date
2193 after creation, if the renaming takes longer than the smallest time difference
2194 that the getModificationTime can measure.
2195
2196 The solution we opt for is a "touch" of the cache file right after it is
2197 created. This resets the modification time of the cache file and the directory
2198 to the current time.
2199
2200 Other possible solutions:
2201 * backdate the modification time of the directory to the modification time
2202 of the cachefile. This is what we used to do on posix platforms. An
2203 observer of the directory would see the modification time of the directory
2204 jump back in time. Not nice, although in practice probably not a problem.
2205 Also note that a cross-platform implementation of setModificationTime is
2206 currently not available.
2207 * set the modification time of the cache file to the modification time of
2208 the directory (instead of the curent time). This could also work,
2209 given that we are the only ones writing to this directory. It would also
2210 require a high-precision getModificationTime (lower precision times get
2211 rounded down it seems), or the cache would still be out-of-date.
2212 * change writeAtomic to create the tempfile outside of the target file's
2213 directory.
2214 * create the cachefile outside of the package.conf.d directory in the first
2215 place. But there are tests and there might be tools that currently rely on
2216 the package.conf.d/package.cache format.
2217 -}