New patch for Ticket #199 - support for a world file

29 Sep 2009


      [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
}