- (final_stack, to_modify) <-
- 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, Nothing)
- else return (reverse (nub db_flags), Nothing)
- 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 my_flags ]
- ++ env_stack
-
- -- the database we actually modify is the one mentioned
- -- rightmost on the command-line.
- to_modify = if null db_flags
- then Just virt_global_conf
- else Just (last db_flags)
- in
- return (flag_stack, to_modify)
-
- db_stack <- mapM readParseDatabase final_stack
- return (db_stack, to_modify)
-
-readParseDatabase :: PackageDBName -> IO (PackageDBName,PackageDB)
-readParseDatabase filename = do
- str <- readFile filename `catchIO` \_ -> return emptyPackageConfig
- let packages = map convertPackageInfoIn $ read str
- Exception.evaluate packages
+ let flag_db_names | null db_flags = env_stack
+ | otherwise = reverse (nub db_flags)
+
+ -- For a "modify" command, treat all the databases as
+ -- a stack, where we are modifying the top one, but it
+ -- can refer to packages in databases further down the
+ -- stack.
+
+ -- -f flags on the command line add to the database
+ -- stack, unless any of them are present in the stack
+ -- already.
+ let final_stack = filter (`notElem` env_stack)
+ [ f | FlagConfig f <- reverse my_flags ]
+ ++ env_stack
+
+ -- the database we actually modify is the one mentioned
+ -- rightmost on the command-line.
+ let to_modify
+ | not modify = Nothing
+ | null db_flags = Just virt_global_conf
+ | otherwise = Just (last db_flags)
+
+ db_stack <- mapM (readParseDatabase verbosity mb_user_conf use_cache) final_stack
+
+ let flag_db_stack = [ db | db_name <- flag_db_names,
+ db <- db_stack, location db == db_name ]
+
+ return (db_stack, to_modify, flag_db_stack)
+
+
+lookForPackageDBIn :: FilePath -> IO (Maybe FilePath)
+lookForPackageDBIn dir = do
+ let path_dir = dir </> "package.conf.d"
+ exists_dir <- doesDirectoryExist path_dir
+ if exists_dir then return (Just path_dir) else do
+ let path_file = dir </> "package.conf"
+ exists_file <- doesFileExist path_file
+ if exists_file then return (Just path_file) else return Nothing
+
+readParseDatabase :: Verbosity
+ -> Maybe (FilePath,Bool)
+ -> Bool -- use cache
+ -> FilePath
+ -> IO PackageDB
+
+readParseDatabase verbosity mb_user_conf use_cache path
+ -- the user database (only) is allowed to be non-existent
+ | Just (user_conf,False) <- mb_user_conf, path == user_conf
+ = return PackageDB { location = path, packages = [] }
+ | otherwise
+ = do e <- tryIO $ getDirectoryContents path
+ case e of
+ Left _ -> do
+ pkgs <- parseMultiPackageConf verbosity path
+ return PackageDB{ location = path, packages = pkgs }
+ Right fs
+ | not use_cache -> ignore_cache
+ | otherwise -> do
+ let cache = path </> cachefilename
+ tdir <- getModificationTime path
+ e_tcache <- 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
+ return PackageDB { location = path, packages = 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
+ return PackageDB { location = path, 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