Commit 84cecac6 authored by Mikhail Glushenkov's avatar Mikhail Glushenkov
Browse files

Merge pull request #2931 from martinvlk/fix#2155

Fix for #2155 including tests
parents c170de48 fb0a0fa5
......@@ -49,7 +49,7 @@ import Distribution.Client.Setup
import Distribution.Client.Sandbox.Timestamp ( listModifiedDeps
, maybeAddCompilerTimestampRecord
, withAddTimestamps
, withRemoveTimestamps )
, removeTimestamps )
import Distribution.Client.Config
( SavedConfig(..), defaultUserInstall, loadConfig )
import Distribution.Client.Dependency ( foldProgress )
......@@ -74,7 +74,7 @@ import Distribution.Client.SetupWrapper
import Distribution.Client.Types ( PackageLocation(..)
, SourcePackage(..) )
import Distribution.Client.Utils ( inDir, tryCanonicalizePath
, tryFindAddSourcePackageDesc )
, tryFindAddSourcePackageDesc)
import Distribution.PackageDescription.Configuration
( flattenPackageDescription )
import Distribution.PackageDescription.Parse ( readPackageDescription )
......@@ -113,8 +113,8 @@ 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' )
import Data.Maybe ( fromJust )
import Data.List ( delete, foldl', intersperse, find, (\\))
import Data.Maybe ( fromJust, fromMaybe )
#if !MIN_VERSION_base(4,8,0)
import Data.Monoid ( mempty, mappend )
#endif
......@@ -452,13 +452,26 @@ sandboxDeleteSource verbosity buildTreeRefs _sandboxFlags globalFlags = do
(sandboxDir, pkgEnv) <- tryLoadSandboxConfig verbosity globalFlags
indexFile <- tryGetIndexFilePath (pkgEnvSavedConfig pkgEnv)
withRemoveTimestamps sandboxDir $ do
Index.removeBuildTreeRefs verbosity indexFile buildTreeRefs
(removedPaths, convDict) <- Index.removeBuildTreeRefs verbosity indexFile buildTreeRefs
removeTimestamps sandboxDir removedPaths
let removedRefs = fmap (convertWith convDict) removedPaths
when (not . null $ removedPaths) $
notice verbosity $ "Success deleting sources: " ++
showL removedRefs ++ "\n\n"
when (length buildTreeRefs > length removedPaths) $
die $ "Skipped the following nonregistered sources: " ++
(showL $ buildTreeRefs \\ removedRefs)
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
-- | Entry point for the 'cabal sandbox list-sources' command.
sandboxListSources :: Verbosity -> SandboxFlags -> GlobalFlags
......
......@@ -39,6 +39,7 @@ 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 System.Directory ( createDirectoryIfMissing,
......@@ -156,31 +157,49 @@ addBuildTreeRefs verbosity path l' refType = do
(path `replaceExtension` "cache")
-- | Remove given local build tree references from the index.
removeBuildTreeRefs :: Verbosity -> FilePath -> [FilePath] -> IO [FilePath]
removeBuildTreeRefs :: Verbosity -> FilePath -> [FilePath]
-> IO ([FilePath], [(FilePath, FilePath)]) -- ^ A tuple consisting of:
-- * removed build tree refs
-- * and mappings from provided
-- build tree refs to corresponding
-- full directory paths)
removeBuildTreeRefs _ _ [] =
error "Distribution.Client.Sandbox.Index.removeBuildTreeRefs: unexpected"
removeBuildTreeRefs verbosity path l' = do
checkIndexExists path
l <- mapM canonicalizePathNoThrow l'
let tmpFile = path <.> "tmp"
removeBuildTreeRefs verbosity indexPath l' = do
checkIndexExists indexPath
let tmpFile = indexPath <.> "tmp"
convDict <- mapM (\btr -> do pth <- canonicalizePathNoThrow btr
return (btr, pth)) l'
-- 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
removedRefs <- doRemove convDict tmpFile
renameFile tmpFile indexPath
debug verbosity $ "Successfully renamed '" ++ tmpFile
++ "' to '" ++ path ++ "'"
updatePackageIndexCacheFile verbosity path (path `replaceExtension` "cache")
-- FIXME: return only the refs that vere actually removed.
return l
++ "' to '" ++ indexPath ++ "'"
updatePackageIndexCacheFile verbosity indexPath (indexPath `replaceExtension` "cache")
return (removedRefs, convDict)
where
p l entry = case readBuildTreeRef entry of
Nothing -> True
doRemove srcRefs tmpFile = do
(newIdx, changedPaths) <- Tar.read `fmap` BS.readFile indexPath
>>= runWriterT . Tar.filterEntriesM (p $ fmap snd srcRefs)
BS.writeFile tmpFile $ Tar.writeEntries newIdx
return changedPaths
p :: [FilePath] -> Tar.Entry -> WriterT [FilePath] IO Bool
p refs entry = case readBuildTreeRef entry of
Nothing -> return True
-- FIXME: removing snapshot deps is done with `delete-source
-- .cabal-sandbox/snapshots/$SNAPSHOT_NAME`. Perhaps we also want to
-- support removing snapshots by providing the original path.
(Just (BuildTreeRef _ pth)) -> pth `notElem` l
(Just (BuildTreeRef _ pth)) -> if pth `elem` refs
then tell [pth] >> return False
else return True
-- | 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
......
......@@ -10,10 +10,10 @@
module Distribution.Client.Sandbox.Timestamp (
AddSourceTimestamp,
withAddTimestamps,
withRemoveTimestamps,
withUpdateTimestamps,
maybeAddCompilerTimestampRecord,
listModifiedDeps,
removeTimestamps,
) where
import Control.Exception (IOException)
......@@ -127,8 +127,8 @@ updateTimestamps timestamps pathsToUpdate newTimestamp =
-- | Given a list of 'TimestampFileRecord's and a list of paths to add-source
-- deps we've removed, remove those deps from the list.
removeTimestamps :: [AddSourceTimestamp] -> [FilePath] -> [AddSourceTimestamp]
removeTimestamps l pathsToRemove = foldr removeTimestamp [] l
removeTimestamps' :: [AddSourceTimestamp] -> [FilePath] -> [AddSourceTimestamp]
removeTimestamps' l pathsToRemove = foldr removeTimestamp [] l
where
removeTimestamp t@(path, _oldTimestamp) rest =
if path `elem` pathsToRemove
......@@ -159,10 +159,11 @@ withAddTimestamps sandboxDir act = do
let initialTimestamp = 0
withActionOnAllTimestamps (addTimestamps initialTimestamp) sandboxDir act
-- | Given an IO action that returns a list of build tree refs, remove those
-- | Given a list of build tree refs, remove those
-- build tree refs from the timestamps file (for all compilers).
withRemoveTimestamps :: FilePath -> IO [FilePath] -> IO ()
withRemoveTimestamps = withActionOnAllTimestamps removeTimestamps
removeTimestamps :: FilePath -> [FilePath] -> IO ()
removeTimestamps idxFile =
withActionOnAllTimestamps removeTimestamps' idxFile . return
-- | Given an IO action that returns a list of build tree refs, update the
-- timestamps of the returned build tree refs to the current time (only for the
......
......@@ -59,10 +59,12 @@ module Distribution.Client.Tar (
-- ** Sequences of tar entries
Entries(..),
foldrEntries,
foldrEntriesM,
foldlEntries,
unfoldrEntries,
mapEntries,
filterEntries,
filterEntriesM,
entriesIndex,
) where
......@@ -71,9 +73,12 @@ import Data.Char (ord)
import Data.Int (Int64)
import Data.Bits (Bits, shiftL, testBit)
import Data.List (foldl')
import Data.Monoid (Monoid(..))
import Numeric (readOct, showOct)
import Control.Applicative (Applicative(..))
import Control.Monad (MonadPlus(mplus), when, ap, liftM)
import Control.Monad.Identity (Identity(..), runIdentity)
import Control.Monad.Writer.Lazy (WriterT(..), runWriterT, tell)
import qualified Data.Map as Map
import qualified Data.ByteString.Lazy as BS
import qualified Data.ByteString.Lazy.Char8 as BS.Char8
......@@ -436,11 +441,14 @@ unfoldrEntries f = unfold
Right (Just (e, x')) -> Next e (unfold x')
foldrEntries :: (Entry -> a -> a) -> a -> (String -> a) -> Entries -> a
foldrEntries next done fail' = fold
foldrEntries next done fail' = isoR . foldrEntriesM (isoL .: next) (isoL done) (isoL . fail')
where
fold (Next e es) = next e (fold es)
fold Done = done
fold (Fail err) = fail' err
isoL :: a -> WriterT () Identity a
isoL = return
f .: g = \e -> f . g e
isoR :: WriterT () Identity a -> a
isoR = fst . runIdentity . runWriterT
foldlEntries :: (a -> Entry -> a) -> a -> Entries -> Either String a
foldlEntries f = fold
......@@ -453,12 +461,25 @@ mapEntries :: (Entry -> Entry) -> Entries -> Entries
mapEntries f = foldrEntries (Next . f) Done Fail
filterEntries :: (Entry -> Bool) -> Entries -> Entries
filterEntries p =
foldrEntries
(\entry rest -> if p entry
then Next entry rest
else rest)
Done Fail
filterEntries p = isoR . filterEntriesM (return . p)
filterEntriesM :: (Monad m) => (Entry -> m Bool) -> Entries -> m Entries
filterEntriesM p =
foldrEntriesM
(\entry rest -> do
include <- p entry
if include
then return $ Next entry rest
else return rest)
(return Done) (return . Fail)
foldrEntriesM :: (Monad m) => (Entry -> a -> m a) -> m a -> (String -> m a) -> Entries -> m a
foldrEntriesM next done fail' = fold
where
fold (Next e es) = fold es >>= next e
fold Done = done
fold (Fail err) = fail' err
checkEntries :: (Entry -> Maybe String) -> Entries -> Entries
checkEntries checkEntry =
......
cabal() {
$CABAL $CABAL_ARGS "$@"
}
die() {
echo "die: $@"
exit 1
}
. ../common.sh
# Create the sandbox
cabal sandbox init > /dev/null
# Add one source
cabal sandbox add-source p > /dev/null
# Remove a source that exists on disk, but is not registered
cabal sandbox delete-source q
name: p
version: 0.1.0.0
license-file: LICENSE
author: Edward Z. Yang
maintainer: ezyang@cs.stanford.edu
build-type: Simple
cabal-version: >=1.10
library
build-depends: base
default-language: Haskell2010
name: q
version: 0.1.0.0
license-file: LICENSE
author: Edward Z. Yang
maintainer: ezyang@cs.stanford.edu
build-type: Simple
cabal-version: >=1.10
library
build-depends: base
default-language: Haskell2010
name: p
version: 0.1.0.0
license-file: LICENSE
author: Edward Z. Yang
maintainer: ezyang@cs.stanford.edu
build-type: Simple
cabal-version: >=1.10
library
build-depends: base
default-language: Haskell2010
name: q
version: 0.1.0.0
license-file: LICENSE
author: Edward Z. Yang
maintainer: ezyang@cs.stanford.edu
build-type: Simple
cabal-version: >=1.10
library
build-depends: base
default-language: Haskell2010
Success deleting sources: "q" "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