Commit 5cd03ccc authored by refold's avatar refold
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).
parent 673ecb2f
-----------------------------------------------------------------------------
-- |
-- 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:
......@@ -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
-- ------------------------------------------------------------
......
......@@ -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
......@@ -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
......
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