[Updated patch for world-file support Peter Robinson <thaldyron@gmail.com>**20090929200551 Ignore-this: 2362afdac5b775f3bc018883da9afd53 This is a new patch for Ticket #199; it adds the "--one-shot" option. A world file entry contains the package-name, package-version, and user flags (if any). For example, the file entry generated by # cabal install stm-io-hooks --flags="-debug" looks like this: # stm-io-hooks -any --flags="-debug" To rebuild/upgrade the packages in world (e.g. when updating the compiler) use # cabal install world Installing package 'foo' without adding it to the world file: # cabal install foo --one-shot ] { hunk ./Distribution/Client/Config.hs 161 + worldFile <- defaultWorldFile hunk ./Distribution/Client/Config.hs 170 + }, + savedGlobalFlags = mempty { + globalWorldFile = toFlag worldFile hunk ./Distribution/Client/Config.hs 186 + worldFile <- defaultWorldFile hunk ./Distribution/Client/Config.hs 190 - globalRemoteRepos = [defaultRemoteRepo] + globalRemoteRepos = [defaultRemoteRepo], + globalWorldFile = toFlag worldFile hunk ./Distribution/Client/Config.hs 217 +-- | Default position of the world file +defaultWorldFile :: IO FilePath +defaultWorldFile = do + dir <- defaultCabalDir + return $ dir </> "world" + hunk ./Distribution/Client/Setup.hs 90 - globalLocalRepos :: [FilePath] + globalLocalRepos :: [FilePath], + globalWorldFile :: Flag FilePath hunk ./Distribution/Client/Setup.hs 101 - globalLocalRepos = mempty + globalLocalRepos = mempty, + globalWorldFile = mempty hunk ./Distribution/Client/Setup.hs 152 + + ,option [] ["world-file"] + "The location of the world file" + globalWorldFile (\v flags -> flags { globalWorldFile = v }) + (reqArgFlag "FILE") hunk ./Distribution/Client/Setup.hs 167 - globalLocalRepos = mempty + globalLocalRepos = mempty, + globalWorldFile = mempty hunk ./Distribution/Client/Setup.hs 176 - globalLocalRepos = combine globalLocalRepos + globalLocalRepos = combine globalLocalRepos, + globalWorldFile = combine globalWorldFile hunk ./Distribution/Client/Setup.hs 468 - installSymlinkBinDir:: Flag FilePath + installSymlinkBinDir:: Flag FilePath, + installOneShot :: Flag Bool hunk ./Distribution/Client/Setup.hs 483 - installSymlinkBinDir= mempty + installSymlinkBinDir= mempty, + installOneShot = Flag False hunk ./Distribution/Client/Setup.hs 571 + , option [] ["one-shot"] + "Do not record the packages in the world file." + installOneShot (\v flags -> flags { installOneShot = v }) + trueArg hunk ./Distribution/Client/Setup.hs 595 - installSymlinkBinDir= mempty + installSymlinkBinDir= mempty, + installOneShot = mempty hunk ./Distribution/Client/Setup.hs 608 - installSymlinkBinDir= combine installSymlinkBinDir + installSymlinkBinDir= combine installSymlinkBinDir, + installOneShot = combine installOneShot hunk ./Distribution/Client/Types.hs 19 - ( GenericPackageDescription, FlagAssignment ) + ( GenericPackageDescription, FlagAssignment, FlagName(FlagName) ) hunk ./Distribution/Client/Types.hs 24 +import Distribution.Text + ( Text(disp,parse) ) +import qualified Distribution.Compat.ReadP as Parse +import qualified Text.PrettyPrint as Disp + $ hunk ./Distribution/Client/Types.hs 30 +import Data.Char as Char hunk ./Distribution/Client/Types.hs 117 - deriving (Show) + deriving (Show,Eq) + + +instance Text UnresolvedDependency where + disp udep = disp (dependency udep) Disp.<+> dispFlags (depFlags udep) + where $ + dispFlags [] = Disp.empty + dispFlags fs = Disp.text "--flags=" $ + Disp.<> $ + (Disp.doubleQuotes $ flagAssToDoc fs) + flagAssToDoc = foldr (\(FlagName fname,val) flagAssDoc -> $ + (if not val then Disp.char '-' $ + else Disp.empty) + Disp.<> Disp.text fname $ + Disp.<+> flagAssDoc) + Disp.empty $ + parse = do + dep <- parse $ + Parse.skipSpaces + flagAss <- Parse.option [] parseFlagAssignment + return $ UnresolvedDependency dep flagAss $ + where + parseFlagAssignment :: Parse.ReadP r FlagAssignment + parseFlagAssignment = do $ + Parse.string "--flags" + Parse.skipSpaces + Parse.char '=' + Parse.skipSpaces + inDoubleQuotes $ Parse.many1 flag + where + inDoubleQuotes :: Parse.ReadP r a -> Parse.ReadP r a + inDoubleQuotes = Parse.between (Parse.char '"') (Parse.char '"') $ + + flag = do + Parse.skipSpaces + val <- negative Parse.+++ positive + name <- ident + Parse.skipSpaces + return (FlagName name,val) + negative = do + Parse.char '-' + return False + positive = return True + + ident :: Parse.ReadP r String + ident = do $ + -- First character must be a letter/digit to avoid flags + -- like "+-debug": + c <- Parse.satisfy Char.isAlphaNum + cs <- Parse.munch (\ch -> Char.isAlphaNum ch || ch == '_' $ + || ch == '-') + return (c:cs) + $ + addfile ./Distribution/Client/World.hs hunk ./Distribution/Client/World.hs 1 +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.World +-- Copyright : (c) Peter Robinson 2009 +-- License : BSD-like +-- +-- Maintainer : thaldyron@gmail.com +-- Stability : provisional +-- Portability : portable +-- +-- Interface to the world-file that contains a list of explicitly $ +-- requested packages. Meant to be imported qualified. +-- +-- A world file entry stores the package-name, package-version, and $ +-- user flags. +-- For example, the entry generated by $ +-- # cabal install stm-io-hooks --flags="-debug" $ +-- looks like this: +-- # stm-io-hooks -any --flags="-debug" +-- To rebuild/upgrade the packages in world (e.g. when updating the compiler) $ +-- use +-- # cabal install world +-- $ +----------------------------------------------------------------------------- +module Distribution.Client.World( insert, $ + delete, + getContents, + worldPkg, + ) +where +import Distribution.Client.Utils( writeFileAtomic ) $ +import Distribution.Client.Types $ + ( UnresolvedDependency(dependency) ) +import Distribution.Package $ + ( PackageName(..), Dependency( Dependency ) ) +import Distribution.Version( anyVersion ) +import Distribution.Text( display, simpleParse ) +import Distribution.Verbosity ( Verbosity ) +import Distribution.Simple.Utils ( die, notice, chattyTry ) +import Data.List( unionBy, deleteFirstsBy, nubBy, all ) +import Data.Maybe( isJust, fromJust ) +import Control.Monad( unless ) +import System.IO.Error( isDoesNotExistError, ) +import qualified Data.ByteString.Lazy.Char8 as B +import Prelude hiding ( getContents ) + + +-- | Adds packages to the world file; creates the file if it doesn't $ +-- exist yet. Flag assignments for a package are updated if already $ +-- present. IO errors are non-fatal. +insert :: Verbosity -> Bool -> FilePath -> [UnresolvedDependency] -> IO () +insert = modifyWorld $ unionBy equalUDep + +-- | Removes packages from the world file. $ +-- Note: Currently unused as there is no mechanism in Cabal (yet) to $ +-- handle uninstalls. IO errors are non-fatal. +delete :: Verbosity -> Bool -> FilePath -> [UnresolvedDependency] -> IO () +delete = modifyWorld $ flip (deleteFirstsBy equalUDep) + +-- | UnresolvedDependency values are considered equal if their dependency +-- is equal, i.e., we don't care about differing flags. +equalUDep :: UnresolvedDependency -> UnresolvedDependency -> Bool +equalUDep u1 u2 = dependency u1 == dependency u2 + +-- | Modifies the world file by applying an update-function ('unionBy' +-- for 'insert', 'deleteFirstsBy' for 'delete') to the given list of $ +-- packages. IO errors are considered non-fatal. +modifyWorld :: ([UnresolvedDependency] -> [UnresolvedDependency] $ + -> [UnresolvedDependency]) $ + -- ^ Function that defines how $ + -- the list of user packages are merged with + -- existing world packages. $ + -> Verbosity $ + -> Bool -- ^ Dry-run? + -> FilePath -- ^ Location of the world file + -> [UnresolvedDependency] -- ^ list of user supplied packages + -> IO () $ +modifyWorld _ _ _ _ [] = return () +modifyWorld f verbosity dryRun world pkgs = $ + chattyTry "Error while updating world-file. " $ do + pkgsOldWorld <- getContents world + -- Filter out packages that are not in the world file: + let pkgsNewWorld = nubBy equalUDep $ f pkgs pkgsOldWorld + -- 'Dependency' is not an Ord instance, so we need to check for $ + -- equivalence the awkward way: + if not (all (`elem` pkgsOldWorld) pkgsNewWorld && + all (`elem` pkgsNewWorld) pkgsOldWorld) $ + then $ + unless dryRun $ do + writeFileAtomic world $ B.unlines $ + [B.pack (display pkg) | pkg <- pkgsNewWorld] + notice verbosity "Updating world-file..." $ + else + notice verbosity "World-file already up to date." + + +-- | Returns the content of the world file as a list +getContents :: FilePath -> IO [UnresolvedDependency] +getContents world = do + content <- safelyReadFile world + let result = map simpleParse (lines . B.unpack $ content) + if all isJust result + then return $ map fromJust result + else die "Could not parse world file." + where $ + safelyReadFile :: FilePath -> IO B.ByteString + safelyReadFile file = B.readFile file `catch` handler $ + where + handler e | isDoesNotExistError e = return B.empty + | otherwise = ioError e $ + + +-- | A dummy package that represents the world file. $ +worldPkg :: Dependency +worldPkg = Dependency (PackageName "world") anyVersion + + hunk ./Main.hs 58 +import qualified Distribution.Client.World as World hunk ./Main.hs 203 + pkgsFlagAss = configConfigurationsFlags configFlags' + pkgsNoWorld = filter (/=World.worldPkg) pkgs $ + -- User-specified packages except 'world': + uDepsNoWorld = [ UnresolvedDependency pkg pkgsFlagAss + | pkg <- pkgsNoWorld ] + worldFile = fromFlag $ globalWorldFile globalFlags' + dryRun = fromFlagOrDefault False (installDryRun installFlags') + oneShot = fromFlagOrDefault False (installOneShot installFlags') + + -- Read packages from the world file if requested: + uDepsFromWorld <- if pkgsNoWorld /= pkgs && not oneShot + then do $ + unless (null pkgsFlagAss) $ $ + die "Package world does not take any flags." + World.getContents worldFile + else return [] hunk ./Main.hs 223 - [ UnresolvedDependency pkg (configConfigurationsFlags configFlags') - | pkg <- pkgs ] + (uDepsFromWorld ++ uDepsNoWorld) + unless oneShot $ World.insert verbosity dryRun worldFile uDepsNoWorld $ hunk ./cabal-install.cabal 73 + Distribution.Client.World }