Extend the index format with references to local build trees.

Also implements a (hidden) 'index' command for debugging (likely to be removed
in the future).

cabal-install/Distribution/Client/Index.hs

+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Distribution.Client.Index
+-- Maintainer  :  cabal-devel@haskell.org
+-- Portability :  portable
+--
+-- Querying and modifying the package index.
+--
+--
+-----------------------------------------------------------------------------
+
+module Distribution.Client.Index (index)
+       where
+
+import qualified Distribution.Client.Tar as Tar
+import Distribution.Client.Setup ( IndexFlags(..) )
+import Distribution.Client.Utils ( makeAbsoluteToCwd )
+
+import Distribution.Simple.Setup ( fromFlagOrDefault )
+import Distribution.Simple.Utils ( die, debug, notice )
+import Distribution.Verbosity    ( Verbosity )
+
+import qualified Data.ByteString.Lazy as BS
+import qualified Data.ByteString.Lazy.Char8 as BS.Char8
+import Control.Monad             ( liftM, when, unless )
+import Data.List                 ( (\\), nub )
+import Data.Maybe                ( catMaybes )
+import System.Directory          ( canonicalizePath,
+                                   doesDirectoryExist, doesFileExist,
+                                   getDirectoryContents, renameFile )
+import System.FilePath           ( (</>), (<.>), takeExtension )
+
+
+-- | A reference to a local build tree.
+data LocalBuildTree = LocalBuildTree {
+  localBuildTreePath :: FilePath
+  }
+
+-- | Type code of the corresponding tar entry type.
+localBuildTreeTypeCode :: Tar.TypeCode
+localBuildTreeTypeCode = 'C'
+
+-- | Given a path, ensure that it refers to a local build tree.
+localBuildTreeFromPath :: FilePath -> IO (Maybe LocalBuildTree)
+localBuildTreeFromPath dir = do
+  dirExists <- doesDirectoryExist dir
+  if dirExists then
+    do fns <- getDirectoryContents dir
+       case filter ((== ".cabal") . takeExtension) fns of
+         [_] -> return . Just $ LocalBuildTree { localBuildTreePath = dir }
+         []  -> die $ "directory '" ++ dir
+                ++ "' doesn't contain a .cabal file"
+         _   -> die $ "directory '" ++ dir
+                ++ "' contains more than one .cabal file"
+    else die $ "directory '" ++ dir ++ "' does not exist"
+
+-- | Given a tar archive entry, try to parse it as a reference to a local build
+-- tree.
+readLocalBuildTree :: Tar.Entry -> Maybe FilePath
+readLocalBuildTree entry = case Tar.entryContent entry of
+  (Tar.OtherEntryType typeCode bs size)
+    | (typeCode == localBuildTreeTypeCode)
+      && (size == BS.length bs) -> Just $ BS.Char8.unpack bs
+    | otherwise                 -> Nothing
+  _ -> Nothing
+
+readLocalBuildTrees :: Tar.Entries -> [FilePath]
+readLocalBuildTrees = catMaybes
+                      . Tar.foldrEntries (\e r -> (readLocalBuildTree e):r)
+                      [] error
+
+readLocalBuildTreesFromFile :: FilePath -> IO [FilePath]
+readLocalBuildTreesFromFile = liftM (readLocalBuildTrees . Tar.read)
+                              . BS.readFile
+
+-- | Given a local build tree, serialise it to a tar archive entry.
+writeLocalBuildTree :: LocalBuildTree -> Tar.Entry
+writeLocalBuildTree lbt = Tar.simpleEntry tarPath content
+  where
+    -- TODO: Use utf8-string or text here.
+    bs       = BS.Char8.pack path
+    path     = localBuildTreePath lbt
+    -- fromRight can't fail because the path is shorter than 255 characters.
+    tarPath  = fromRight $ Tar.toTarPath True tarPath'
+    -- Provide a filename for tools that treat custom entries as ordinary files.
+    tarPath' = "local-build-tree-reference"
+    content  = Tar.OtherEntryType localBuildTreeTypeCode bs (BS.length bs)
+
+    -- TODO: Move this to D.C.Utils?
+    fromRight (Left err) = error err
+    fromRight (Right a)  = a
+
+
+-- | Entry point for the 'cabal index' command.
+index :: Verbosity -> IndexFlags -> FilePath -> IO ()
+index verbosity indexFlags path' = do
+  let runInit = fromFlagOrDefault False (indexInit indexFlags)
+  let linkSource = indexLinkSource indexFlags
+  let runLinkSource = not . null $ linkSource
+  let removeSource = indexRemoveSource indexFlags
+  let runRemoveSource = not . null $ removeSource
+  let runList = fromFlagOrDefault False (indexList indexFlags)
+
+  unless (or [runInit, runLinkSource, runRemoveSource, runList]) $ do
+    die "no arguments passed to the 'index' command"
+
+  path <- validateIndexPath path'
+
+  when runInit $ do
+    indexExists <- doesFileExist path
+    if indexExists
+      then die $ "index already exists: '" ++ path ++ "'"
+      else doInit verbosity path
+
+  indexExists <- doesFileExist path
+  when (not indexExists) $ do
+    die $ "index does not exist: '" ++ path ++ "'"
+
+  when runLinkSource $ do
+    doLinkSource verbosity path linkSource
+
+  when runRemoveSource $ do
+    doRemoveSource verbosity path removeSource
+
+  when runList $ do
+    doList verbosity path
+
+-- | Check that the provided path is either an existing directory, or a tar
+-- archive in an existing directory.
+validateIndexPath :: FilePath -> IO FilePath
+validateIndexPath path' = do
+   path <- makeAbsoluteToCwd path'
+   if (== ".tar") . takeExtension $ path
+     then return path
+     else do dirExists <- doesDirectoryExist path
+             unless dirExists $ do
+               die $ "directory does not exist: '" ++ path ++ "'"
+             return $ path </> "00-index.tar"
+
+-- | Create an empty index file (index --init).
+doInit :: Verbosity -> FilePath -> IO ()
+doInit verbosity path = do
+  debug verbosity $ "Creating the index file '" ++ path ++ "'"
+  -- Equivalent to 'tar cvf empty.tar --files-from /dev/null'.
+  let zeros = BS.replicate (512*20) 0
+  BS.writeFile path zeros
+
+-- | Add a reference to a local build tree to the index.
+doLinkSource :: Verbosity -> FilePath -> [FilePath] -> IO ()
+doLinkSource _         _   [] =
+  error "Distribution.Client.Index.doLinkSource: unexpected"
+doLinkSource verbosity path l' = do
+  l <- liftM nub . mapM canonicalizePath $ l'
+  treesInIndex <- readLocalBuildTreesFromFile path
+  -- Add only those paths that aren't already in the index.
+  treesToAdd <- mapM localBuildTreeFromPath (l \\ treesInIndex)
+  let entries = map writeLocalBuildTree (catMaybes treesToAdd)
+  when (not . null $ entries) $ do
+    let tmpFile = path <.> "tmp"
+    -- TODO: Calculate the offset and append instead of rewriting. Complicated
+    -- by the fact that a tar archive can have a nondeterministic number of
+    -- trailing zeros after two obligatory zero blocks, so searching for the
+    -- last entry from the end is problematic.
+    BS.writeFile tmpFile . Tar.appendEntries entries. Tar.read
+      =<< BS.readFile path
+    renameFile tmpFile path
+    debug verbosity $ "Successfully renamed '" ++ tmpFile
+      ++ "' to '" ++ path ++ "'"
+
+
+-- | Remove a reference to a local build tree to the index.
+doRemoveSource :: Verbosity -> FilePath -> [FilePath] -> IO ()
+doRemoveSource _         _   [] =
+  error "Distribution.Client.Index.doRemoveSource: unexpected"
+doRemoveSource verbosity path l' = do
+  l <- mapM canonicalizePath l'
+  let tmpFile = path <.> "tmp"
+  -- Performance note: on my system, it takes 'index --remove-source'
+  -- approx. 3,5s to filter a 65M file. Real-life indices are expected to be
+  -- much smaller.
+  BS.writeFile tmpFile . Tar.writeEntries . Tar.filterEntries (p l) . Tar.read
+    =<< BS.readFile path
+  renameFile tmpFile path
+  debug verbosity $ "Successfully renamed '" ++ tmpFile
+    ++ "' to '" ++ path ++ "'"
+    where
+      p l entry = case readLocalBuildTree entry of
+        Nothing    -> True
+        (Just pth) -> not $ any (== pth) l
+
+-- | List the local build trees that are referred to from the index.
+doList :: Verbosity -> FilePath -> IO ()
+doList verbosity path = do
+  localTrees <- readLocalBuildTreesFromFile path
+  when (null localTrees) $ do
+    notice verbosity $ "Index file '" ++ path
+      ++ "' has no references to local build trees."
+  mapM_ putStrLn localTrees

cabal-install/Distribution/Client/Setup.hs

@@ -28,6 +28,7 @@ module Distribution.Client.Setup
     , initCommand, IT.InitFlags(..)
     , sdistCommand, SDistFlags(..), SDistExFlags(..), ArchiveFormat(..)
     , win32SelfUpgradeCommand, Win32SelfUpgradeFlags(..)
+    , indexCommand, IndexFlags(..)
 
     , parsePackageArgs
     --TODO: stop exporting these:
@@ -1154,6 +1155,79 @@ instance Monoid Win32SelfUpgradeFlags where
   }
     where combine field = field a `mappend` field b
 
+-- ------------------------------------------------------------
+-- * Index flags
+-- ------------------------------------------------------------
+
+data IndexFlags = IndexFlags {
+  indexInit         :: Flag Bool,
+  indexList         :: Flag Bool,
+  indexLinkSource   :: [FilePath],
+  indexRemoveSource :: [String],
+  indexVerbosity    :: Flag Verbosity
+}
+
+defaultIndexFlags :: IndexFlags
+defaultIndexFlags = IndexFlags {
+  indexInit         = mempty,
+  indexList         = mempty,
+  indexLinkSource   = [],
+  indexRemoveSource = [],
+  indexVerbosity    = toFlag normal
+}
+
+indexCommand :: CommandUI IndexFlags
+indexCommand = CommandUI {
+  commandName         = "index",
+  commandSynopsis     = "Query and modify the index file",
+  commandDescription  = Nothing,
+  commandUsage        = \pname ->
+    "Usage: " ++ pname ++ " index FLAGS PATH\n\n"
+     ++ "Flags for index:",
+  commandDefaultFlags = defaultIndexFlags,
+  commandOptions      = \_ ->
+      [optionVerbosity indexVerbosity
+       (\v flags -> flags { indexVerbosity = v})
+
+      ,option [] ["init"]
+       "Create the index"
+       indexInit (\v flags -> flags { indexInit = v })
+       trueArg
+
+      ,option [] ["link-source"]
+       "Add a reference to a local build tree to the index"
+       indexLinkSource (\v flags -> flags { indexLinkSource = v })
+       (reqArg' "PATH" (\x -> [x]) id)
+
+      ,option [] ["remove-source"]
+       "Remove a reference to a local build tree from the index"
+       indexRemoveSource (\v flags -> flags { indexRemoveSource = v })
+       (reqArg' "PATH" (\x -> [x]) id)
+
+      ,option [] ["list"]
+       "List the local build trees that are referred to from the index"
+       indexList (\v flags -> flags { indexList = v })
+       trueArg
+      ]
+}
+
+instance Monoid IndexFlags where
+  mempty = IndexFlags {
+    indexInit         = mempty,
+    indexList         = mempty,
+    indexLinkSource   = mempty,
+    indexRemoveSource = mempty,
+    indexVerbosity    = mempty
+  }
+  mappend a b = IndexFlags {
+    indexInit         = combine indexInit,
+    indexList         = combine indexList,
+    indexLinkSource   = combine indexLinkSource,
+    indexRemoveSource = combine indexRemoveSource,
+    indexVerbosity    = combine indexVerbosity
+  }
+    where combine field = field a `mappend` field b
+
 -- ------------------------------------------------------------
 -- * GetOpt Utils
 -- ------------------------------------------------------------

cabal-install/Distribution/Client/Tar.hs

@@ -21,6 +21,8 @@ module Distribution.Client.Tar (
   -- * Converting between internal and external representation
   read,
   write,
+  writeEntries,
+  appendEntries,
 
   -- * Packing and unpacking files to\/from internal representation
   pack,
@@ -657,6 +659,18 @@ instance Monad Partial where
 write :: [Entry] -> ByteString
 write es = BS.concat $ map putEntry es ++ [BS.replicate (512*2) 0]
 
+-- | Same as 'write', but for 'Entries'.
+writeEntries :: Entries -> ByteString
+writeEntries = appendEntries []
+
+-- | Same as 'writeEntries', but additionally appends entries from @es@ to the end.
+appendEntries :: [Entry] -> Entries -> ByteString
+appendEntries es entries =
+  BS.concat $ foldrEntries (\e r -> (putEntry e):r) es' error entries
+  ++ [BS.replicate (512*2) 0]
+  where
+    es' = map putEntry es
+
 putEntry :: Entry -> ByteString
 putEntry entry = case entryContent entry of
   NormalFile       content size -> BS.concat [ header, content, padding size ]

cabal-install/Distribution/Client/Utils.hs

@@ -5,6 +5,8 @@ import Data.List
 import System.Directory
          ( doesFileExist, getModificationTime
          , getCurrentDirectory, setCurrentDirectory )
+import System.FilePath
+         ( (</>), isAbsolute )
 import qualified Control.Exception as Exception
          ( finally )
 
@@ -58,3 +60,10 @@ inDir (Just d) m = do
   old <- getCurrentDirectory
   setCurrentDirectory d
   m `Exception.finally` setCurrentDirectory old
+
+-- | Given a relative path, make it absolute relative to the current
+-- directory. Absolute paths are returned unmodified.
+makeAbsoluteToCwd :: FilePath -> IO FilePath
+makeAbsoluteToCwd path | isAbsolute path = return path
+                       | otherwise       = do cwd <- getCurrentDirectory
+                                              return $! cwd </> path

cabal-install/Main.hs

@@ -29,6 +29,7 @@ import Distribution.Client.Setup
          , InitFlags(initVerbosity), initCommand
          , SDistFlags(..), SDistExFlags(..), sdistCommand
          , Win32SelfUpgradeFlags(..), win32SelfUpgradeCommand
+         , IndexFlags(..), indexCommand
          , reportCommand
          , unpackCommand, UnpackFlags(..) )
 import Distribution.Simple.Setup
@@ -59,6 +60,7 @@ import Distribution.Client.Check as Check   (check)
 import Distribution.Client.Upload as Upload (upload, check, report)
 import Distribution.Client.SrcDist          (sdist)
 import Distribution.Client.Unpack           (unpack)
+import Distribution.Client.Index            (index)
 import Distribution.Client.Init             (initCabal)
 import qualified Distribution.Client.Win32SelfUpgrade as Win32SelfUpgrade
 
@@ -83,7 +85,7 @@ import System.FilePath          (splitExtension, takeExtension)
 import System.Directory         (doesFileExist)
 import Data.List                (intersperse)
 import Data.Monoid              (Monoid(..))
-import Control.Monad            (unless)
+import Control.Monad            (when, unless)
 
 -- | Entry point
 --
@@ -156,6 +158,8 @@ mainWorker args = topHandler $
       ,upgradeCommand         `commandAddAction` upgradeAction
       ,hiddenCommand $
        win32SelfUpgradeCommand`commandAddAction` win32SelfUpgradeAction
+      ,hiddenCommand $
+       indexCommand `commandAddAction` indexAction
       ]
 
 wrapperAction :: Monoid flags
@@ -372,6 +376,15 @@ initAction initFlags _extraArgs globalFlags = do
             conf
             initFlags
 
+indexAction :: IndexFlags -> [String] -> GlobalFlags -> IO ()
+indexAction indexFlags extraArgs _globalFlags = do
+  when (null extraArgs) $ do
+    die $ "the 'index' command expects a single argument. "
+  when ((>1). length $ extraArgs) $ do
+    die $ "the 'index' command expects a single argument: " ++ unwords extraArgs
+  let verbosity = fromFlag (indexVerbosity indexFlags)
+  index verbosity indexFlags (head extraArgs)
+
 -- | See 'Distribution.Client.Install.withWin32SelfUpgrade' for details.
 --
 win32SelfUpgradeAction :: Win32SelfUpgradeFlags -> [String] -> GlobalFlags

cabal-install/cabal-install.cabal

@@ -78,6 +78,7 @@ Executable cabal
         Distribution.Client.GZipUtils
         Distribution.Client.Haddock
         Distribution.Client.HttpUtils
+        Distribution.Client.Index
         Distribution.Client.IndexUtils
         Distribution.Client.Init
         Distribution.Client.Init.Heuristics