Permalink
Browse files

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).
  • Loading branch information...
1 parent 673ecb2 commit 5cd03ccc1aa5ca097c416281aa443edea4eab2fc @23Skidoo 23Skidoo committed Jun 19, 2012
@@ -0,0 +1,198 @@
+-----------------------------------------------------------------------------
+-- |
+-- 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
@@ -28,6 +28,7 @@ module Distribution.Client.Setup
, initCommand, IT.InitFlags(..)
, sdistCommand, SDistFlags(..), SDistExFlags(..), ArchiveFormat(..)
, win32SelfUpgradeCommand, Win32SelfUpgradeFlags(..)
+ , indexCommand, IndexFlags(..)
, parsePackageArgs
--TODO: stop exporting these:
@@ -1155,6 +1156,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
-- ------------------------------------------------------------
@@ -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 ]
@@ -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
View
@@ -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
@@ -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

0 comments on commit 5cd03cc

Please sign in to comment.