- final_stack <-
- if not modify
- then -- For a "read" command, we use all the databases
- -- specified on the command line. If there are no
- -- command-line flags specifying databases, the default
- -- is to use all the ones we know about.
- if null db_flags then return env_stack
- else return (reverse (nub db_flags))
- else let
- -- 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.
- flag_stack = filter (`notElem` env_stack)
- [ f | FlagConfig f <- reverse flags ]
- ++ env_stack
-
- modifying f
- | f `elem` flag_stack = return (dropWhile (/= f) flag_stack)
- | otherwise = die ("requesting modification of database:\n\t" ++ f ++ "\n\twhich is not in the database stack.")
- in
- if null db_flags
- then modifying virt_global_conf
- else modifying (head db_flags)
-
- db_stack <- mapM readParseDatabase final_stack
- return db_stack
-
-readParseDatabase :: PackageDBName -> IO (PackageDBName,PackageDB)
-readParseDatabase filename = do
- str <- readFile filename `Exception.catch` \_ -> return emptyPackageConfig
- let packages = read str
- Exception.evaluate packages
- `Exception.catch` \e->
- die ("error while parsing " ++ filename ++ ": " ++ show e)
- return (filename,packages)
-
-emptyPackageConfig :: String
-emptyPackageConfig = "[]"
+ let flag_db_names | null db_flags = env_stack
+ | otherwise = reverse (nub db_flags)
+
+ -- For a "modify" command, treat all the databases as
+ -- a stack, where we are modifying the top one, but it
+ -- can refer to packages in databases further down the
+ -- stack.
+
+ -- -f flags on the command line add to the database
+ -- stack, unless any of them are present in the stack
+ -- already.
+ let final_stack = filter (`notElem` env_stack)
+ [ f | FlagConfig f <- reverse my_flags ]
+ ++ env_stack
+
+ -- the database we actually modify is the one mentioned
+ -- rightmost on the command-line.
+ let to_modify
+ | not modify = Nothing
+ | null db_flags = Just virt_global_conf
+ | otherwise = Just (last db_flags)
+
+ db_stack <- sequence
+ [ do db <- readParseDatabase verbosity mb_user_conf use_cache db_path
+ if expand_vars then return (mungePackageDBPaths top_dir db)
+ else return db
+ | db_path <- final_stack ]
+
+ let flag_db_stack = [ db | db_name <- flag_db_names,
+ db <- db_stack, location db == db_name ]
+
+ return (db_stack, to_modify, flag_db_stack)
+
+
+lookForPackageDBIn :: FilePath -> IO (Maybe FilePath)
+lookForPackageDBIn dir = do
+ let path_dir = dir </> "package.conf.d"
+ exists_dir <- doesDirectoryExist path_dir
+ if exists_dir then return (Just path_dir) else do
+ let path_file = dir </> "package.conf"
+ exists_file <- doesFileExist path_file
+ if exists_file then return (Just path_file) else return Nothing
+
+readParseDatabase :: Verbosity
+ -> Maybe (FilePath,Bool)
+ -> Bool -- use cache
+ -> FilePath
+ -> IO PackageDB
+
+readParseDatabase verbosity mb_user_conf use_cache path
+ -- the user database (only) is allowed to be non-existent
+ | Just (user_conf,False) <- mb_user_conf, path == user_conf
+ = mkPackageDB []
+ | otherwise
+ = do e <- tryIO $ getDirectoryContents path
+ case e of
+ Left _ -> do
+ pkgs <- parseMultiPackageConf verbosity path
+ mkPackageDB pkgs
+ Right fs
+ | not use_cache -> ignore_cache
+ | otherwise -> do
+ let cache = path </> cachefilename
+ tdir <- getModificationTime path
+ e_tcache <- tryIO $ getModificationTime cache
+ case e_tcache of
+ Left ex -> do
+ when (verbosity > Normal) $
+ warn ("warning: cannot read cache file " ++ cache ++ ": " ++ show ex)
+ ignore_cache
+ Right tcache
+ | tcache >= tdir -> do
+ when (verbosity > Normal) $
+ putStrLn ("using cache: " ++ cache)
+ pkgs <- myReadBinPackageDB cache
+ let pkgs' = map convertPackageInfoIn pkgs
+ mkPackageDB pkgs'
+ | otherwise -> do
+ when (verbosity >= Normal) $ do
+ warn ("WARNING: cache is out of date: " ++ cache)
+ warn " use 'ghc-pkg recache' to fix."
+ ignore_cache
+ where
+ ignore_cache = do
+ let confs = filter (".conf" `isSuffixOf`) fs
+ pkgs <- mapM (parseSingletonPackageConf verbosity) $
+ map (path </>) confs
+ mkPackageDB pkgs
+ where
+ mkPackageDB pkgs = do
+ path_abs <- absolutePath path
+ return PackageDB {
+ location = path,
+ locationAbsolute = path_abs,
+ packages = pkgs
+ }
+
+-- read the package.cache file strictly, to work around a problem with
+-- bytestring 0.9.0.x (fixed in 0.9.1.x) where the file wasn't closed
+-- after it has been completely read, leading to a sharing violation
+-- later.
+myReadBinPackageDB :: FilePath -> IO [InstalledPackageInfoString]
+myReadBinPackageDB filepath = do
+ h <- openBinaryFile filepath ReadMode
+ sz <- hFileSize h
+ b <- B.hGet h (fromIntegral sz)
+ hClose h
+ return $ Bin.runGet Bin.get b
+
+parseMultiPackageConf :: Verbosity -> FilePath -> IO [InstalledPackageInfo]
+parseMultiPackageConf verbosity file = do
+ when (verbosity > Normal) $ putStrLn ("reading package database: " ++ file)
+ str <- readUTF8File file
+ let pkgs = map convertPackageInfoIn $ read str
+ Exception.evaluate pkgs
+ `catchError` \e->
+ die ("error while parsing " ++ file ++ ": " ++ show e)
+
+parseSingletonPackageConf :: Verbosity -> FilePath -> IO InstalledPackageInfo
+parseSingletonPackageConf verbosity file = do
+ when (verbosity > Normal) $ putStrLn ("reading package config: " ++ file)
+ readUTF8File file >>= fmap fst . parsePackageInfo
+
+cachefilename :: FilePath
+cachefilename = "package.cache"
+
+mungePackageDBPaths :: FilePath -> PackageDB -> PackageDB
+mungePackageDBPaths top_dir db@PackageDB { packages = pkgs } =
+ db { packages = map (mungePackagePaths top_dir pkgroot) pkgs }
+ where
+ pkgroot = takeDirectory (locationAbsolute db)
+ -- It so happens that for both styles of package db ("package.conf"
+ -- files and "package.conf.d" dirs) the pkgroot is the parent directory
+ -- ${pkgroot}/package.conf or ${pkgroot}/package.conf.d/
+
+mungePackagePaths :: FilePath -> FilePath
+ -> InstalledPackageInfo -> InstalledPackageInfo
+-- Perform path/URL variable substitution as per the Cabal ${pkgroot} spec
+-- (http://www.haskell.org/pipermail/libraries/2009-May/011772.html)
+-- Paths/URLs can be relative to ${pkgroot} or ${pkgrooturl}.
+-- The "pkgroot" is the directory containing the package database.
+--
+-- Also perform a similar substitution for the older GHC-specific
+-- "$topdir" variable. The "topdir" is the location of the ghc
+-- installation (obtained from the -B option).
+mungePackagePaths top_dir pkgroot pkg =
+ pkg {
+ importDirs = munge_paths (importDirs pkg),
+ includeDirs = munge_paths (includeDirs pkg),
+ libraryDirs = munge_paths (libraryDirs pkg),
+ frameworkDirs = munge_paths (frameworkDirs pkg),
+ haddockInterfaces = munge_paths (haddockInterfaces pkg),
+ haddockHTMLs = munge_urls (haddockHTMLs pkg)
+ }
+ where
+ munge_paths = map munge_path
+ munge_urls = map munge_url
+
+ munge_path p
+ | Just p' <- stripVarPrefix "${pkgroot}" sp = pkgroot </> p'
+ | Just p' <- stripVarPrefix "$topdir" sp = top_dir </> p'
+ | otherwise = p
+ where
+ sp = splitPath p
+
+ munge_url p
+ | Just p' <- stripVarPrefix "${pkgrooturl}" sp = toUrlPath pkgroot p'
+ | Just p' <- stripVarPrefix "$httptopdir" sp = toUrlPath top_dir p'
+ | otherwise = p
+ where
+ sp = splitPath p
+
+ toUrlPath r p = "file:///"
+ -- URLs always use posix style '/' separators:
+ ++ FilePath.Posix.joinPath (r : FilePath.splitDirectories p)
+
+ stripVarPrefix var (root:path')
+ | Just [sep] <- stripPrefix var root
+ , isPathSeparator sep
+ = Just (joinPath path')
+
+ stripVarPrefix _ _ = Nothing
+
+
+-- -----------------------------------------------------------------------------
+-- Creating a new package DB
+
+initPackageDB :: FilePath -> Verbosity -> [Flag] -> IO ()
+initPackageDB filename verbosity _flags = do
+ let eexist = die ("cannot create: " ++ filename ++ " already exists")
+ b1 <- doesFileExist filename
+ when b1 eexist
+ b2 <- doesDirectoryExist filename
+ when b2 eexist
+ filename_abs <- absolutePath filename
+ changeDB verbosity [] PackageDB {
+ location = filename, locationAbsolute = filename_abs,
+ packages = []
+ }