Commit 4e59ffca authored by Peter Robinson's avatar Peter Robinson

Updated patch for world-file support

Update 2: now uses writeFileAtomic from Cabal
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
parent 488ade06
......@@ -157,6 +157,7 @@ updateInstallDirs userInstallFlag
baseSavedConfig :: IO SavedConfig
baseSavedConfig = do
userPrefix <- defaultCabalDir
worldFile <- defaultWorldFile
return mempty {
savedConfigureFlags = mempty {
configHcFlavor = toFlag defaultCompiler,
......@@ -165,6 +166,9 @@ baseSavedConfig = do
},
savedUserInstallDirs = mempty {
prefix = toFlag (toPathTemplate userPrefix)
},
savedGlobalFlags = mempty {
globalWorldFile = toFlag worldFile
}
}
......@@ -178,10 +182,12 @@ initialSavedConfig :: IO SavedConfig
initialSavedConfig = do
cacheDir <- defaultCacheDir
logsDir <- defaultLogsDir
worldFile <- defaultWorldFile
return mempty {
savedGlobalFlags = mempty {
globalCacheDir = toFlag cacheDir,
globalRemoteRepos = [defaultRemoteRepo]
globalRemoteRepos = [defaultRemoteRepo],
globalWorldFile = toFlag worldFile
},
savedInstallFlags = mempty {
installSummaryFile = [toPathTemplate (logsDir </> "build.log")],
......@@ -207,6 +213,12 @@ defaultLogsDir = do
dir <- defaultCabalDir
return $ dir </> "logs"
-- | Default position of the world file
defaultWorldFile :: IO FilePath
defaultWorldFile = do
dir <- defaultCabalDir
return $ dir </> "world"
defaultCompiler :: CompilerFlavor
defaultCompiler = fromMaybe GHC defaultCompilerFlavor
......
......@@ -92,7 +92,8 @@ data GlobalFlags = GlobalFlags {
globalConfigFile :: Flag FilePath,
globalRemoteRepos :: [RemoteRepo], -- ^Available Hackage servers.
globalCacheDir :: Flag FilePath,
globalLocalRepos :: [FilePath]
globalLocalRepos :: [FilePath],
globalWorldFile :: Flag FilePath
}
defaultGlobalFlags :: GlobalFlags
......@@ -102,7 +103,8 @@ defaultGlobalFlags = GlobalFlags {
globalConfigFile = mempty,
globalRemoteRepos = [],
globalCacheDir = mempty,
globalLocalRepos = mempty
globalLocalRepos = mempty,
globalWorldFile = mempty
}
globalCommand :: CommandUI GlobalFlags
......@@ -152,6 +154,11 @@ globalCommand = CommandUI {
"The location of a local repository"
globalLocalRepos (\v flags -> flags { globalLocalRepos = v })
(reqArg' "DIR" (\x -> [x]) id)
,option [] ["world-file"]
"The location of the world file"
globalWorldFile (\v flags -> flags { globalWorldFile = v })
(reqArgFlag "FILE")
]
}
......@@ -162,7 +169,8 @@ instance Monoid GlobalFlags where
globalConfigFile = mempty,
globalRemoteRepos = mempty,
globalCacheDir = mempty,
globalLocalRepos = mempty
globalLocalRepos = mempty,
globalWorldFile = mempty
}
mappend a b = GlobalFlags {
globalVersion = combine globalVersion,
......@@ -170,7 +178,8 @@ instance Monoid GlobalFlags where
globalConfigFile = combine globalConfigFile,
globalRemoteRepos = combine globalRemoteRepos,
globalCacheDir = combine globalCacheDir,
globalLocalRepos = combine globalLocalRepos
globalLocalRepos = combine globalLocalRepos,
globalWorldFile = combine globalWorldFile
}
where combine field = field a `mappend` field b
......@@ -461,7 +470,8 @@ data InstallFlags = InstallFlags {
installSummaryFile :: [PathTemplate],
installLogFile :: Flag PathTemplate,
installBuildReports :: Flag ReportLevel,
installSymlinkBinDir:: Flag FilePath
installSymlinkBinDir:: Flag FilePath,
installOneShot :: Flag Bool
}
defaultInstallFlags :: InstallFlags
......@@ -475,7 +485,8 @@ defaultInstallFlags = InstallFlags {
installSummaryFile = mempty,
installLogFile = mempty,
installBuildReports = Flag NoReports,
installSymlinkBinDir= mempty
installSymlinkBinDir= mempty,
installOneShot = Flag False
}
where
docIndexFile = toPathTemplate ("$datadir" </> "doc" </> "index.html")
......@@ -562,6 +573,10 @@ installOptions showOrParseArgs =
(toFlag `fmap` parse))
(flagToList . fmap display))
, option [] ["one-shot"]
"Do not record the packages in the world file."
installOneShot (\v flags -> flags { installOneShot = v })
trueArg
] ++ case showOrParseArgs of -- TODO: remove when "cabal install" avoids
ParseArgs ->
option [] ["only"]
......@@ -582,7 +597,8 @@ instance Monoid InstallFlags where
installSummaryFile = mempty,
installLogFile = mempty,
installBuildReports = mempty,
installSymlinkBinDir= mempty
installSymlinkBinDir= mempty,
installOneShot = mempty
}
mappend a b = InstallFlags {
installDocumentation= combine installDocumentation,
......@@ -594,7 +610,8 @@ instance Monoid InstallFlags where
installSummaryFile = combine installSummaryFile,
installLogFile = combine installLogFile,
installBuildReports = combine installBuildReports,
installSymlinkBinDir= combine installSymlinkBinDir
installSymlinkBinDir= combine installSymlinkBinDir,
installOneShot = combine installOneShot
}
where combine field = field a `mappend` field b
......
......@@ -18,12 +18,18 @@ import Distribution.Package
import Distribution.InstalledPackageInfo
( InstalledPackageInfo )
import Distribution.PackageDescription
( GenericPackageDescription, FlagAssignment )
( GenericPackageDescription, FlagAssignment, FlagName(FlagName) )
import Distribution.Client.PackageIndex
( PackageIndex )
import Distribution.Version
( VersionRange )
import Distribution.Text
( Text(disp,parse) )
import qualified Distribution.Compat.ReadP as Parse
import qualified Text.PrettyPrint as Disp
import Data.Char as Char
import Data.Map (Map)
import Network.URI (URI)
import Distribution.Compat.Exception
......@@ -133,7 +139,60 @@ data UnresolvedDependency
{ dependency :: Dependency
, depFlags :: FlagAssignment
}
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)
type BuildResult = Either BuildFailure BuildSuccess
data BuildFailure = DependentFailed PackageId
......
-----------------------------------------------------------------------------
-- |
-- 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.Simple.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 $ unlines
[ (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
......@@ -57,6 +57,7 @@ import Distribution.Client.SrcDist (sdist)
import Distribution.Client.Unpack (unpack)
import Distribution.Client.Init (initCabal)
import qualified Distribution.Client.Win32SelfUpgrade as Win32SelfUpgrade
import qualified Distribution.Client.World as World
import Distribution.Simple.Compiler
( PackageDB(..), PackageDBStack )
......@@ -202,12 +203,28 @@ installAction (configFlags, configExFlags, installFlags)
installFlags' = defaultInstallFlags `mappend`
savedInstallFlags config `mappend` installFlags
globalFlags' = savedGlobalFlags config `mappend` globalFlags
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 []
(comp, conf) <- configCompilerAux configFlags'
install verbosity
(configPackageDB' configFlags') (globalRepos globalFlags')
comp conf configFlags' configExFlags' installFlags'
[ UnresolvedDependency pkg (configConfigurationsFlags configFlags')
| pkg <- pkgs ]
(uDepsFromWorld ++ uDepsNoWorld)
unless oneShot $ World.insert verbosity dryRun worldFile uDepsNoWorld
listAction :: ListFlags -> [String] -> GlobalFlags -> IO ()
listAction listFlags extraArgs globalFlags = do
......
......@@ -78,6 +78,7 @@ Executable cabal
Distribution.Client.Update
Distribution.Client.Upload
Distribution.Client.Utils
Distribution.Client.World
Distribution.Client.Win32SelfUpgrade
Distribution.Compat.Exception
Paths_cabal_install
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment