import System.Environment ( getArgs, getProgName, getEnv )
import System.IO
import System.IO.Error (try)
-import Data.List ( isPrefixOf, isSuffixOf, intersperse, sortBy, nub,
- unfoldr, break, partition )
-#if __GLASGOW_HASKELL__ > 604
-import Data.List ( isInfixOf )
-#else
-import Data.List ( tails )
-#endif
+import Data.List
import Control.Concurrent
-#ifdef mingw32_HOST_OS
import Foreign
-import Foreign.C.String
+import Foreign.C
+#ifdef mingw32_HOST_OS
import GHC.ConsoleHandler
#else
-import System.Posix
+import System.Posix hiding (fdToHandle)
#endif
-import IO ( isPermissionError, isDoesNotExistError )
+import IO ( isPermissionError )
+import System.Posix.Internals
+import GHC.Handle (fdToHandle)
#if defined(GLOB)
import System.Process(runInteractiveCommand)
type PackageDBName = FilePath
type PackageDB = [InstalledPackageInfo]
-type PackageDBStack = [(PackageDBName,PackageDB)]
+type NamedPackageDB = (PackageDBName, PackageDB)
+type PackageDBStack = [NamedPackageDB]
-- A stack of package databases. Convention: head is the topmost
-- in the stack. Earlier entries override later one.
allPackagesInStack :: PackageDBStack -> [InstalledPackageInfo]
allPackagesInStack = concatMap snd
-getPkgDatabases :: Bool -> [Flag] -> IO PackageDBStack
+getPkgDatabases :: Bool -> [Flag] -> IO (PackageDBStack, Maybe PackageDBName)
getPkgDatabases modify my_flags = do
-- first we determine the location of the global package config. On Windows,
-- this is found relative to the ghc-pkg.exe binary, whereas on Unix the
user_conf = dir </> subdir </> "package.conf"
user_exists <- doesFileExist user_conf
return (Just (user_conf,user_exists))
- Left ex ->
+ Left _ ->
return Nothing
-- If the user database doesn't exist, and this command isn't a
Right path
| last cs == "" -> init cs ++ sys_databases
| otherwise -> cs
- where cs = splitSearchPath path
+ where cs = parseSearchPath path
-- The "global" database is always the one at the bottom of the stack.
-- This is the database we modify by default.
let db_flags = [ f | Just f <- map is_db_flag my_flags ]
where is_db_flag FlagUser
- | Just (user_conf,user_exists) <- mb_user_conf
+ | Just (user_conf, _user_exists) <- mb_user_conf
= Just user_conf
is_db_flag FlagGlobal = Just virt_global_conf
is_db_flag (FlagConfig f) = Just f
is_db_flag _ = Nothing
- final_stack <-
+ (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
- else return (reverse (nub db_flags))
+ 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
[ f | FlagConfig f <- reverse my_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.")
+ -- 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
- if null db_flags
- then modifying virt_global_conf
- else modifying (head db_flags)
+ return (flag_stack, to_modify)
db_stack <- mapM readParseDatabase final_stack
- return db_stack
+ return (db_stack, to_modify)
readParseDatabase :: PackageDBName -> IO (PackageDBName,PackageDB)
readParseDatabase filename = do
-> Force
-> IO ()
registerPackage input my_flags auto_ghci_libs update force = do
- db_stack <- getPkgDatabases True my_flags
+ (db_stack, Just to_modify) <- getPkgDatabases True my_flags
let
- db_to_operate_on = my_head "db" db_stack
- db_filename = fst db_to_operate_on
+ db_to_operate_on = my_head "register" $
+ filter ((== to_modify).fst) db_stack
--
-
s <-
case input of
"-" -> do
pkg <- parsePackageInfo expanded
putStrLn "done."
- validatePackageConfig pkg db_stack auto_ghci_libs update force
+ let truncated_stack = dropWhile ((/= to_modify).fst) db_stack
+ -- truncate the stack for validation, because we don't allow
+ -- packages lower in the stack to refer to those higher up.
+ validatePackageConfig pkg truncated_stack auto_ghci_libs update force
let new_details = filter not_this (snd db_to_operate_on) ++ [pkg]
not_this p = package p /= package pkg
- writeNewConfig db_filename new_details
+ writeNewConfig to_modify new_details
parsePackageInfo
:: String
-> Force
-> IO ()
modifyPackage fn pkgid my_flags force = do
- db_stack <- getPkgDatabases True{-modify-} my_flags
- let old_broken = brokenPackages (allPackagesInStack db_stack)
- let ((db_name, pkgs) : rest_of_stack) = db_stack
- ps <- findPackages [(db_name,pkgs)] (Id pkgid)
- let pids = map package ps
- let new_config = concat (map modify pkgs)
+ (db_stack, Just _to_modify) <- getPkgDatabases True{-modify-} my_flags
+ ((db_name, pkgs), ps) <- fmap head $ findPackagesByDB db_stack (Id pkgid)
+-- let ((db_name, pkgs) : rest_of_stack) = db_stack
+-- ps <- findPackages [(db_name,pkgs)] (Id pkgid)
+ let
+ pids = map package ps
modify pkg
| package pkg `elem` pids = fn pkg
| otherwise = [pkg]
- let new_stack = (db_name,new_config) : rest_of_stack
+ new_config = concat (map modify pkgs)
+
+ let
+ old_broken = brokenPackages (allPackagesInStack db_stack)
+ rest_of_stack = [ (nm, mypkgs)
+ | (nm, mypkgs) <- db_stack, nm /= db_name ]
+ new_stack = (db_name,new_config) : rest_of_stack
new_broken = map package (brokenPackages (allPackagesInStack new_stack))
newly_broken = filter (`notElem` map package old_broken) new_broken
-
+ --
when (not (null newly_broken)) $
dieOrForceAll force ("unregistering " ++ display pkgid ++
" would break the following packages: "
listPackages :: [Flag] -> Maybe PackageArg -> Maybe (String->Bool) -> IO ()
listPackages my_flags mPackageName mModuleName = do
let simple_output = FlagSimpleOutput `elem` my_flags
- db_stack <- getPkgDatabases False my_flags
+ (db_stack, _) <- getPkgDatabases False my_flags
let db_stack_filtered -- if a package is given, filter out all other packages
| Just this <- mPackageName =
map (\(conf,pkgs) -> (conf, filter (this `matchesPkg`) pkgs))
latestPackage :: [Flag] -> PackageIdentifier -> IO ()
latestPackage my_flags pkgid = do
- db_stack <- getPkgDatabases False my_flags
+ (db_stack, _) <- getPkgDatabases False my_flags
ps <- findPackages db_stack (Id pkgid)
show_pkg (sortBy compPkgIdVer (map package ps))
where
describePackage :: [Flag] -> PackageArg -> IO ()
describePackage my_flags pkgarg = do
- db_stack <- getPkgDatabases False my_flags
+ (db_stack, _) <- getPkgDatabases False my_flags
ps <- findPackages db_stack pkgarg
doDump ps
dumpPackages :: [Flag] -> IO ()
dumpPackages my_flags = do
- db_stack <- getPkgDatabases False my_flags
+ (db_stack, _) <- getPkgDatabases False my_flags
doDump (allPackagesInStack db_stack)
doDump :: [InstalledPackageInfo] -> IO ()
-- PackageId is can have globVersion for the version
findPackages :: PackageDBStack -> PackageArg -> IO [InstalledPackageInfo]
findPackages db_stack pkgarg
- = case [ p | p <- all_pkgs, pkgarg `matchesPkg` p ] of
- [] -> dieWith 2 ("cannot find package " ++ pkg_msg pkgarg)
+ = fmap (concatMap snd) $ findPackagesByDB db_stack pkgarg
+
+findPackagesByDB :: PackageDBStack -> PackageArg
+ -> IO [(NamedPackageDB, [InstalledPackageInfo])]
+findPackagesByDB db_stack pkgarg
+ = case [ (db, matched)
+ | db@(_, pkgs) <- db_stack,
+ let matched = filter (pkgarg `matchesPkg`) pkgs,
+ not (null matched) ] of
+ [] -> die ("cannot find package " ++ pkg_msg pkgarg)
ps -> return ps
where
- all_pkgs = allPackagesInStack db_stack
pkg_msg (Id pkgid) = display pkgid
- pkg_msg (Substring pkgpat _) = "matching "++pkgpat
+ pkg_msg (Substring pkgpat _) = "matching " ++ pkgpat
matches :: PackageIdentifier -> PackageIdentifier -> Bool
pid `matches` pid'
describeField :: [Flag] -> PackageArg -> [String] -> IO ()
describeField my_flags pkgarg fields = do
- db_stack <- getPkgDatabases False my_flags
+ (db_stack, _) <- getPkgDatabases False my_flags
fns <- toFields fields
ps <- findPackages db_stack pkgarg
let top_dir = takeDirectory (fst (last db_stack))
checkConsistency :: [Flag] -> IO ()
checkConsistency my_flags = do
- db_stack <- getPkgDatabases True my_flags
+ (db_stack, _) <- getPkgDatabases True my_flags
-- check behaves like modify for the purposes of deciding which
-- databases to use, because ordering is important.
let pkgs = allPackagesInStack db_stack
where
go avail not_avail =
case partition (depsAvailable avail) not_avail of
- ([], not_avail) -> not_avail
- (new_avail, not_avail) -> go (new_avail ++ avail) not_avail
+ ([], not_avail') -> not_avail'
+ (new_avail, not_avail') -> go (new_avail ++ avail) not_avail'
depsAvailable :: [InstalledPackageInfo] -> InstalledPackageInfo
-> Bool
checkPackageId pkg
checkDuplicates db_stack pkg update force
mapM_ (checkDep db_stack force) (depends pkg)
+ checkDuplicateDepends force (depends pkg)
mapM_ (checkDir force) (importDirs pkg)
mapM_ (checkDir force) (libraryDirs pkg)
mapM_ (checkDir force) (includeDirs pkg)
all_pkgs = allPackagesInStack db_stack
pkgids = map package all_pkgs
+checkDuplicateDepends :: Force -> [PackageIdentifier] -> IO ()
+checkDuplicateDepends force deps
+ | null dups = return ()
+ | otherwise = dieOrForceAll force ("package has duplicate dependencies: " ++
+ unwords (map display dups))
+ where
+ dups = [ p | (p:_:_) <- group (sort deps) ]
+
realVersion :: PackageIdentifier -> Bool
realVersion pkgid = versionBranch (pkgVersion pkgid) /= []
handler' e = Exception.throw e
#endif
+#if mingw32_HOST_OS || mingw32_TARGET_OS
throwIOIO :: Exception.IOException -> IO a
#if __GLASGOW_HASKELL__ >= 609
throwIOIO = Exception.throwIO
#else
throwIOIO ioe = Exception.throwIO (Exception.IOException ioe)
#endif
+#endif
catchError :: IO a -> (String -> IO a) -> IO a
#if __GLASGOW_HASKELL__ >= 609
handler' e = Exception.throw e
#endif
-onException :: IO a -> IO () -> IO a
+onException :: IO a -> IO b -> IO a
#if __GLASGOW_HASKELL__ >= 609
onException = Exception.onException
#else
-- to use text files here, rather than binary files.
writeFileAtomic :: FilePath -> String -> IO ()
writeFileAtomic targetFile content = do
- (tmpFile, tmpHandle) <- openTempFile targetDir template
- do hPutStr tmpHandle content
- hClose tmpHandle
+ (newFile, newHandle) <- openNewFile targetDir template
+ do hPutStr newHandle content
+ hClose newHandle
#if mingw32_HOST_OS || mingw32_TARGET_OS
- renameFile tmpFile targetFile
+ renameFile newFile targetFile
-- If the targetFile exists then renameFile will fail
`catchIO` \err -> do
exists <- doesFileExist targetFile
if exists
then do removeFile targetFile
-- Big fat hairy race condition
- renameFile tmpFile targetFile
+ renameFile newFile targetFile
-- If the removeFile succeeds and the renameFile fails
-- then we've lost the atomic property.
else throwIOIO err
#else
- renameFile tmpFile targetFile
+ renameFile newFile targetFile
#endif
- `onException` do hClose tmpHandle
- removeFile tmpFile
+ `onException` do hClose newHandle
+ removeFile newFile
where
template = targetName <.> "tmp"
targetDir | null targetDir_ = "."
--TODO: remove this when takeDirectory/splitFileName is fixed
-- to always return a valid dir
(targetDir_,targetName) = splitFileName targetFile
+
+-- Ugh, this is a copy/paste of code from the base library, but
+-- if uses 666 rather than 600 for the permissions.
+openNewFile :: FilePath -> String -> IO (FilePath, Handle)
+openNewFile dir template = do
+ pid <- c_getpid
+ findTempName pid
+ where
+ -- We split off the last extension, so we can use .foo.ext files
+ -- for temporary files (hidden on Unix OSes). Unfortunately we're
+ -- below filepath in the hierarchy here.
+ (prefix,suffix) =
+ case break (== '.') $ reverse template of
+ -- First case: template contains no '.'s. Just re-reverse it.
+ (rev_suffix, "") -> (reverse rev_suffix, "")
+ -- Second case: template contains at least one '.'. Strip the
+ -- dot from the prefix and prepend it to the suffix (if we don't
+ -- do this, the unique number will get added after the '.' and
+ -- thus be part of the extension, which is wrong.)
+ (rev_suffix, '.':rest) -> (reverse rest, '.':reverse rev_suffix)
+ -- Otherwise, something is wrong, because (break (== '.')) should
+ -- always return a pair with either the empty string or a string
+ -- beginning with '.' as the second component.
+ _ -> error "bug in System.IO.openTempFile"
+
+ oflags = rw_flags .|. o_EXCL
+
+ findTempName x = do
+ fd <- withCString filepath $ \ f ->
+ c_open f oflags 0o666
+ if fd < 0
+ then do
+ errno <- getErrno
+ if errno == eEXIST
+ then findTempName (x+1)
+ else ioError (errnoToIOError "openNewBinaryFile" errno Nothing (Just dir))
+ else do
+ -- XXX We want to tell fdToHandle what the filepath is,
+ -- as any exceptions etc will only be able to report the
+ -- fd currently
+ h <-
+#if __GLASGOW_HASKELL__ >= 609
+ fdToHandle fd
+#else
+ fdToHandle (fromIntegral fd)
+#endif
+ `onException` c_close fd
+ return (filepath, h)
+ where
+ filename = prefix ++ show x ++ suffix
+ filepath = dir `combine` filename
+
+-- XXX Copied from GHC.Handle
+std_flags, output_flags, rw_flags :: CInt
+std_flags = o_NONBLOCK .|. o_NOCTTY
+output_flags = std_flags .|. o_CREAT
+rw_flags = output_flags .|. o_RDWR
+
+-- | The function splits the given string to substrings
+-- using 'isSearchPathSeparator'.
+parseSearchPath :: String -> [FilePath]
+parseSearchPath path = split path
+ where
+ split :: String -> [String]
+ split s =
+ case rest' of
+ [] -> [chunk]
+ _:rest -> chunk : split rest
+ where
+ chunk =
+ case chunk' of
+#ifdef mingw32_HOST_OS
+ ('\"':xs@(_:_)) | last xs == '\"' -> init xs
+#endif
+ _ -> chunk'
+
+ (chunk', rest') = break isSearchPathSeparator s
projects / ghc-hetmet.git / blobdiff