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 ...@@ -28,6 +28,7 @@ module Distribution.Client.Setup
, initCommand, IT.InitFlags(..) , initCommand, IT.InitFlags(..)
, sdistCommand, SDistFlags(..), SDistExFlags(..), ArchiveFormat(..) , sdistCommand, SDistFlags(..), SDistExFlags(..), ArchiveFormat(..)
, win32SelfUpgradeCommand, Win32SelfUpgradeFlags(..) , win32SelfUpgradeCommand, Win32SelfUpgradeFlags(..)
, indexCommand, IndexFlags(..)
, parsePackageArgs , parsePackageArgs
--TODO: stop exporting these: --TODO: stop exporting these:
...@@ -1154,6 +1155,79 @@ instance Monoid Win32SelfUpgradeFlags where ...@@ -1154,6 +1155,79 @@ instance Monoid Win32SelfUpgradeFlags where
} }
where combine field = field a `mappend` field b 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 -- * GetOpt Utils
-- ------------------------------------------------------------ -- ------------------------------------------------------------
......
...@@ -21,6 +21,8 @@ module Distribution.Client.Tar ( ...@@ -21,6 +21,8 @@ module Distribution.Client.Tar (
-- * Converting between internal and external representation -- * Converting between internal and external representation
read, read,
write, write,
writeEntries,
appendEntries,
-- * Packing and unpacking files to\/from internal representation -- * Packing and unpacking files to\/from internal representation
pack, pack,
...@@ -657,6 +659,18 @@ instance Monad Partial where ...@@ -657,6 +659,18 @@ instance Monad Partial where
write :: [Entry] -> ByteString write :: [Entry] -> ByteString
write es = BS.concat $ map putEntry es ++ [BS.replicate (512*2) 0] 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 -> ByteString
putEntry entry = case entryContent entry of putEntry entry = case entryContent entry of
NormalFile content size -> BS.concat [ header, content, padding size ] NormalFile content size -> BS.concat [ header, content, padding size ]
......
...@@ -5,6 +5,8 @@ import Data.List ...@@ -5,6 +5,8 @@ import Data.List
import System.Directory import System.Directory
( doesFileExist, getModificationTime ( doesFileExist, getModificationTime
, getCurrentDirectory, setCurrentDirectory ) , getCurrentDirectory, setCurrentDirectory )
import System.FilePath
( (</>), isAbsolute )
import qualified Control.Exception as Exception import qualified Control.Exception as Exception
( finally ) ( finally )
...@@ -58,3 +60,10 @@ inDir (Just d) m = do ...@@ -58,3 +60,10 @@ inDir (Just d) m = do
old <- getCurrentDirectory old <- getCurrentDirectory
setCurrentDirectory d setCurrentDirectory d
m `Exception.finally` setCurrentDirectory old 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 ...@@ -29,6 +29,7 @@ import Distribution.Client.Setup
, InitFlags(initVerbosity), initCommand , InitFlags(initVerbosity), initCommand
, SDistFlags(..), SDistExFlags(..), sdistCommand , SDistFlags(..), SDistExFlags(..), sdistCommand
, Win32SelfUpgradeFlags(..), win32SelfUpgradeCommand , Win32SelfUpgradeFlags(..), win32SelfUpgradeCommand
, IndexFlags(..), indexCommand
, reportCommand , reportCommand
, unpackCommand, UnpackFlags(..) ) , unpackCommand, UnpackFlags(..) )
import Distribution.Simple.Setup import Distribution.Simple.Setup
...@@ -59,6 +60,7 @@ import Distribution.Client.Check as Check (check) ...@@ -59,6 +60,7 @@ import Distribution.Client.Check as Check (check)
import Distribution.Client.Upload as Upload (upload, check, report) import Distribution.Client.Upload as Upload (upload, check, report)
import Distribution.Client.SrcDist (sdist) import Distribution.Client.SrcDist (sdist)
import Distribution.Client.Unpack (unpack) import Distribution.Client.Unpack (unpack)
import Distribution.Client.Index (index)
import Distribution.Client.Init (initCabal) import Distribution.Client.Init (initCabal)
import qualified Distribution.Client.Win32SelfUpgrade as Win32SelfUpgrade import qualified Distribution.Client.Win32SelfUpgrade as Win32SelfUpgrade
...@@ -83,7 +85,7 @@ import System.FilePath (splitExtension, takeExtension) ...@@ -83,7 +85,7 @@ import System.FilePath (splitExtension, takeExtension)
import System.Directory (doesFileExist) import System.Directory (doesFileExist)
import Data.List (intersperse) import Data.List (intersperse)
import Data.Monoid (Monoid(..)) import Data.Monoid (Monoid(..))
import Control.Monad (unless) import Control.Monad (when, unless)
-- | Entry point -- | Entry point
-- --
...@@ -156,6 +158,8 @@ mainWorker args = topHandler $ ...@@ -156,6 +158,8 @@ mainWorker args = topHandler $
,upgradeCommand `commandAddAction` upgradeAction ,upgradeCommand `commandAddAction` upgradeAction
,hiddenCommand $ ,hiddenCommand $
win32SelfUpgradeCommand`commandAddAction` win32SelfUpgradeAction win32SelfUpgradeCommand`commandAddAction` win32SelfUpgradeAction
,hiddenCommand $
indexCommand `commandAddAction` indexAction
] ]
wrapperAction :: Monoid flags wrapperAction :: Monoid flags
...@@ -372,6 +376,15 @@ initAction initFlags _extraArgs globalFlags = do ...@@ -372,6 +376,15 @@ initAction initFlags _extraArgs globalFlags = do
conf conf
initFlags 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. -- | See 'Distribution.Client.Install.withWin32SelfUpgrade' for details.
-- --
win32SelfUpgradeAction :: Win32SelfUpgradeFlags -> [String] -> GlobalFlags win32SelfUpgradeAction :: Win32SelfUpgradeFlags -> [String] -> GlobalFlags
......
...@@ -78,6 +78,7 @@ Executable cabal ...@@ -78,6 +78,7 @@ Executable cabal
Distribution.Client.GZipUtils Distribution.Client.GZipUtils
Distribution.Client.Haddock Distribution.Client.Haddock
Distribution.Client.HttpUtils Distribution.Client.HttpUtils
Distribution.Client.Index
Distribution.Client.IndexUtils Distribution.Client.IndexUtils
Distribution.Client.Init Distribution.Client.Init
Distribution.Client.Init.Heuristics 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