Commit 622dec55 authored by martinvlk's avatar martinvlk
Browse files

Implement better error handling for "sandbox delete-source".

parent ff184105
......@@ -58,7 +58,7 @@ import Distribution.Simple.Utils
( die, warn, info, fromUTF8, ignoreBOM )
import Data.Char (isAlphaNum)
import Data.Maybe (mapMaybe)
import Data.Maybe (mapMaybe, catMaybes)
import Data.List (isPrefixOf)
#if !MIN_VERSION_base(4,8,0)
import Data.Monoid (Monoid(..))
......@@ -75,7 +75,7 @@ import Distribution.Client.Utils ( byteStringToFilePath
, tryFindAddSourcePackageDesc )
import Distribution.Compat.Exception (catchIO)
import Distribution.Client.Compat.Time (getFileAge, getModTime)
import System.Directory (doesFileExist)
import System.Directory (doesFileExist, doesDirectoryExist)
import System.FilePath ((</>), takeExtension, splitDirectories, normalise)
import System.FilePath.Posix as FilePath.Posix
( takeFileName )
......@@ -245,7 +245,7 @@ typeCodeFromRefType :: BuildTreeRefType -> Tar.TypeCode
typeCodeFromRefType LinkRef = Tar.buildTreeRefTypeCode
typeCodeFromRefType SnapshotRef = Tar.buildTreeSnapshotTypeCode
type MkPackageEntry = IO PackageEntry
type MkPackageEntry = IO (Maybe PackageEntry)
instance Package PackageEntry where
packageId (NormalPackage pkgid _ _ _) = pkgid
......@@ -262,7 +262,7 @@ packageDesc (BuildTreeRef _ _ descr _ _) = descr
data PackageOrDep = Pkg PackageEntry | Dep Dependency
parsePackageIndex :: ByteString
-> [IO PackageOrDep]
-> [IO (Maybe PackageOrDep)]
parsePackageIndex = accum 0 . Tar.read
where
accum blockNo es = case es of
......@@ -280,11 +280,11 @@ parsePackageIndex = accum 0 . Tar.read
tryExtractPkg = do
mkPkgEntry <- maybeToList $ extractPkg entry blockNo
return (fmap Pkg mkPkgEntry)
return $ fmap (fmap Pkg) mkPkgEntry
tryExtractPrefs = do
(_,prefs') <- maybeToList $ extractPrefs entry
map (return . Dep) $ prefs'
fmap (return . Just . Dep) prefs'
extractPkg :: Tar.Entry -> BlockNo -> Maybe MkPackageEntry
extractPkg entry blockNo = case Tar.entryContent entry of
......@@ -292,7 +292,7 @@ extractPkg entry blockNo = case Tar.entryContent entry of
| takeExtension fileName == ".cabal"
-> case splitDirectories (normalise fileName) of
[pkgname,vers,_] -> case simpleParse vers of
Just ver -> Just $ return (NormalPackage pkgid descr content blockNo)
Just ver -> Just . return $ Just (NormalPackage pkgid descr content blockNo)
where
pkgid = PackageIdentifier (PackageName pkgname) ver
parsed = parsePackageDescription . ignoreBOM . fromUTF8 . BS.Char8.unpack
......@@ -307,12 +307,15 @@ extractPkg entry blockNo = case Tar.entryContent entry of
Tar.OtherEntryType typeCode content _
| Tar.isBuildTreeRefTypeCode typeCode ->
Just $ do
let path = byteStringToFilePath content
err = "Error reading package index."
cabalFile <- tryFindAddSourcePackageDesc path err
descr <- PackageDesc.Parse.readPackageDescription normal cabalFile
return $ BuildTreeRef (refTypeFromTypeCode typeCode) (packageId descr)
descr path blockNo
let path = byteStringToFilePath content
dirExists <- doesDirectoryExist path
result <- if not dirExists then return Nothing
else do
cabalFile <- tryFindAddSourcePackageDesc path "Error reading package index."
descr <- PackageDesc.Parse.readPackageDescription normal cabalFile
return . Just $ BuildTreeRef (refTypeFromTypeCode typeCode) (packageId descr)
descr path blockNo
return result
_ -> Nothing
......@@ -353,7 +356,7 @@ updatePackageIndexCacheFile verbosity indexFile cacheFile = do
. maybeDecompress
=<< BS.readFile indexFile
entries <- lazySequence pkgsOrPrefs
let cache = map toCache entries
let cache = map toCache $ catMaybes entries
writeFile cacheFile (showIndexCache cache)
where
toCache (Pkg (NormalPackage pkgid _ _ blockNo)) = CachePackageId pkgid blockNo
......
......@@ -108,13 +108,14 @@ import qualified Distribution.Simple.PackageIndex as InstalledPackageIndex
import qualified Distribution.Simple.Register as Register
import qualified Data.Map as M
import qualified Data.Set as S
import Data.Either (partitionEithers)
import Control.Exception ( assert, bracket_ )
import Control.Monad ( forM, liftM2, unless, when )
import Data.Bits ( shiftL, shiftR, xor )
import Data.Char ( ord )
import Data.IORef ( newIORef, writeIORef, readIORef )
import Data.List ( delete, foldl', intersperse, find, (\\))
import Data.Maybe ( fromJust, fromMaybe )
import Data.List ( delete, foldl', intersperse, groupBy)
import Data.Maybe ( fromJust )
#if !MIN_VERSION_base(4,8,0)
import Data.Monoid ( mempty, mappend )
#endif
......@@ -132,7 +133,6 @@ import System.FilePath ( (</>), equalFilePath
, searchPathSeparator
, takeDirectory )
--
-- * Constants
--
......@@ -452,26 +452,53 @@ sandboxDeleteSource verbosity buildTreeRefs _sandboxFlags globalFlags = do
(sandboxDir, pkgEnv) <- tryLoadSandboxConfig verbosity globalFlags
indexFile <- tryGetIndexFilePath (pkgEnvSavedConfig pkgEnv)
(removedPaths, convDict) <- Index.removeBuildTreeRefs verbosity indexFile buildTreeRefs
removeTimestamps sandboxDir removedPaths
(results, convDict) <-
Index.removeBuildTreeRefs verbosity indexFile buildTreeRefs
let (failedPaths, removedPaths) = partitionEithers results
removedRefs = fmap convDict removedPaths
let removedRefs = fmap (convertWith convDict) removedPaths
unless (null removedPaths) $ do
removeTimestamps sandboxDir removedPaths
when (not . null $ removedPaths) $
notice verbosity $ "Success deleting sources: " ++
showL removedRefs ++ "\n\n"
showL removedRefs ++ "\n\n"
when (length buildTreeRefs > length removedPaths) $
die $ "Skipped the following nonregistered sources: " ++
(showL $ buildTreeRefs \\ removedRefs)
unless (null failedPaths) $ do
let groupedFailures = groupBy errorType failedPaths
mapM_ handleErrors groupedFailures
die $ "The sources with the above errors were skipped. (" ++
showL (fmap getPath failedPaths) ++ ")"
notice verbosity $ "Note: 'sandbox delete-source' only unregisters the " ++
"source dependency, but does not remove the package " ++
"from the sandbox package DB.\n\n" ++
"Use 'sandbox hc-pkg -- unregister' to do that."
where
convertWith dict pth = fromMaybe pth $ fmap fst $ find ((==pth) . snd) dict
showL = concat . intersperse " " . fmap show
getPath (Index.ErrNonregisteredSource p) = p
getPath (Index.ErrNonexistentSource p) = p
showPaths f = concat . intersperse " " . fmap (show . f)
showL = showPaths id
showE [] = return ' '
showE errs = showPaths getPath errs
errorType Index.ErrNonregisteredSource{} Index.ErrNonregisteredSource{} =
True
errorType Index.ErrNonexistentSource{} Index.ErrNonexistentSource{} = True
errorType _ _ = False
handleErrors [] = return ()
handleErrors errs@(Index.ErrNonregisteredSource{}:_) =
warn verbosity ("Sources not registered: " ++ showE errs ++ "\n\n")
handleErrors errs@(Index.ErrNonexistentSource{}:_) =
warn verbosity
("Source directory not found for paths: " ++ showE errs ++ "\n"
++ "If you are trying to delete a reference to a removed directory, "
++ "please provide the full absolute path "
++ "(as given by `sandbox list-sources`).\n\n")
-- | Entry point for the 'cabal sandbox list-sources' command.
sandboxListSources :: Verbosity -> SandboxFlags -> GlobalFlags
......@@ -560,8 +587,10 @@ loadConfigOrSandboxConfig verbosity globalFlags = do
-- Neither @cabal.sandbox.config@ nor @cabal.config@ are present.
AmbientPackageEnvironment -> do
config <- loadConfig verbosity configFileFlag
let globalConstraintsOpt = flagToMaybe . globalConstraintsFile . savedGlobalFlags $ config
globalConstraintConfig <- loadUserConfig verbosity pkgEnvDir globalConstraintsOpt
let globalConstraintsOpt =
flagToMaybe . globalConstraintsFile . savedGlobalFlags $ config
globalConstraintConfig <-
loadUserConfig verbosity pkgEnvDir globalConstraintsOpt
let config' = config `mappend` globalConstraintConfig
dieIfSandboxRequired config
return (NoSandbox, config')
......@@ -652,7 +681,9 @@ reinstallAddSourceDeps verbosity configFlags' configExFlags
die' message = die (message ++ installFailedInSandbox)
-- TODO: use a better error message, remove duplication.
installFailedInSandbox =
"Note: when using a sandbox, all packages are required to have consistent dependencies. Try reinstalling/unregistering the offending packages or recreating the sandbox."
"Note: when using a sandbox, all packages are required to have consistent "
++ "dependencies. Try reinstalling/unregistering the offending packages "
++ "or recreating the sandbox."
logMsg message rest = debugNoWrap verbosity message >> rest
topHandler' = topHandlerWith $ \_ -> do
......
......@@ -12,6 +12,7 @@ module Distribution.Client.Sandbox.Index (
addBuildTreeRefs,
removeBuildTreeRefs,
ListIgnoredBuildTreeRefs(..), RefTypesToList(..),
DeleteSourceError(..),
listBuildTreeRefs,
validateIndexPath,
......@@ -30,21 +31,22 @@ import Distribution.Client.Types ( Repo(..), LocalRepo(..)
, SourcePackage(..), PackageLocation(..) )
import Distribution.Client.Utils ( byteStringToFilePath, filePathToByteString
, makeAbsoluteToCwd, tryCanonicalizePath
, canonicalizePathNoThrow
, tryFindAddSourcePackageDesc )
import Distribution.Simple.Utils ( die, debug )
import Distribution.Compat.Exception ( tryIO )
import Distribution.Verbosity ( Verbosity )
import qualified Data.ByteString.Lazy as BS
import Control.Exception ( evaluate )
import Control.Monad ( liftM, unless )
import Control.Monad.Writer.Lazy (WriterT(..), runWriterT, tell)
import Data.List ( (\\), intersect, nub )
import Data.Maybe ( catMaybes )
import Data.List ( (\\), intersect, nub, find )
import Data.Maybe ( catMaybes, fromMaybe )
import Data.Either (partitionEithers)
import System.Directory ( createDirectoryIfMissing,
doesDirectoryExist, doesFileExist,
renameFile )
renameFile, canonicalizePath)
import System.FilePath ( (</>), (<.>), takeDirectory, takeExtension
, replaceExtension )
import System.IO ( IOMode(..), SeekMode(..)
......@@ -156,32 +158,47 @@ addBuildTreeRefs verbosity path l' refType = do
updatePackageIndexCacheFile verbosity path
(path `replaceExtension` "cache")
data DeleteSourceError = ErrNonregisteredSource { nrPath :: FilePath }
| ErrNonexistentSource { nePath :: FilePath } deriving Show
-- | Remove given local build tree references from the index.
--
-- Returns a tuple consisting of removed build tree refs and mappings from
-- provided build tree refs to corresponding full directory paths).
-- Returns a tuple with either removed build tree refs or errors and a function
-- that converts from a provided build tree ref to corresponding full directory path.
removeBuildTreeRefs :: Verbosity -> FilePath -> [FilePath]
-> IO ([FilePath], [(FilePath, FilePath)])
-> IO ([Either DeleteSourceError FilePath],
(FilePath -> FilePath))
removeBuildTreeRefs _ _ [] =
error "Distribution.Client.Sandbox.Index.removeBuildTreeRefs: unexpected"
removeBuildTreeRefs verbosity indexPath l = do
checkIndexExists indexPath
let tmpFile = indexPath <.> "tmp"
convDict <- mapM (\btr -> do pth <- canonicalizePathNoThrow btr
return (btr, pth)) l
canonRes <- mapM (\btr -> do res <- tryIO $ canonicalizePath btr
return $ case res of
Right pth -> Right (btr, pth)
Left _ -> Left $ ErrNonexistentSource btr) l
let (failures, convDict) = partitionEithers canonRes
allRefs = fmap snd convDict
-- 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.
removedRefs <- doRemove convDict tmpFile
renameFile tmpFile indexPath
debug verbosity $ "Successfully renamed '" ++ tmpFile
++ "' to '" ++ indexPath ++ "'"
updatePackageIndexCacheFile verbosity indexPath
(indexPath `replaceExtension` "cache")
return (removedRefs, convDict)
unless (null removedRefs) $
updatePackageIndexCacheFile verbosity indexPath (indexPath `replaceExtension` "cache")
let results = fmap Right removedRefs
++ fmap Left failures
++ fmap (Left . ErrNonregisteredSource)
(fmap (convertWith convDict) (allRefs \\ removedRefs))
return (results, convertWith convDict)
where
doRemove :: [(FilePath, FilePath)] -> FilePath -> IO [FilePath]
......@@ -202,6 +219,8 @@ removeBuildTreeRefs verbosity indexPath l = do
then tell [pth] >> return False
else return True
convertWith dict pth = fromMaybe pth $ fmap fst $ find ((==pth) . snd) dict
-- | A build tree ref can become ignored if the user later adds a build tree ref
-- with the same package ID. We display ignored build tree refs when the user
-- runs 'cabal sandbox list-sources', but do not look at their timestamps in
......
Warning: Source directory not found for paths: "p"
If you are trying to delete a reference to a removed directory, please provide
the full absolute path (as given by `sandbox list-sources`).
cabal: The sources with the above errors were skipped. ("p")
......@@ -8,8 +8,7 @@ cabal sandbox add-source p > /dev/null
cabal sandbox add-source q > /dev/null
# delete the directory on disk
# FIXME: the following line needs to be uncommented, but this depends on fixing a regression to #1360 first
#rm -R p
rm -R p
# Remove the registered source which is no longer on disk
cabal sandbox delete-source p
cabal: Skipped the following nonregistered sources: "q"
Warning: Source directory not found for paths: "r" "s"
If you are trying to delete a reference to a removed directory, please provide
the full absolute path (as given by `sandbox list-sources`).
Warning: Sources not registered: "q"
cabal: The sources with the above errors were skipped. ("r" "s" "q")
......@@ -7,4 +7,4 @@ cabal sandbox init > /dev/null
cabal sandbox add-source p > /dev/null
# Remove a source that exists on disk, but is not registered
cabal sandbox delete-source q
cabal sandbox delete-source q r s
Success deleting sources: "p"
Note: 'sandbox delete-source' only unregisters the source dependency, but does
not remove the package from the sandbox package DB.
Use 'sandbox hc-pkg -- unregister' to do that.
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