diff options
| -rw-r--r-- | Command/Unused.hs | 41 | ||||
| -rw-r--r-- | Git/DiffTree.hs | 20 | ||||
| -rw-r--r-- | Test.hs | 20 |
3 files changed, 64 insertions, 17 deletions
diff --git a/Command/Unused.hs b/Command/Unused.hs index b38c254ff..e6c8e225c 100644 --- a/Command/Unused.hs +++ b/Command/Unused.hs @@ -27,6 +27,7 @@ import qualified Annex import qualified Git import qualified Git.Command import qualified Git.Ref +import qualified Git.Branch import qualified Git.LsFiles as LsFiles import qualified Git.DiffTree as DiffTree import qualified Backend @@ -253,35 +254,49 @@ withKeysReferenced' mdir initial a = do go v' fs withKeysReferencedInGit :: (Key -> Annex ()) -> Annex () -withKeysReferencedInGit a = - showref >>= mapM_ (withKeysReferencedInGitRef a) . relevantrefs +withKeysReferencedInGit a = do + current <- inRepo Git.Branch.currentUnsafe + shaHead <- maybe (return Nothing) (inRepo . Git.Ref.sha) current + showref >>= mapM_ (withKeysReferencedInGitRef a) . + relevantrefs (shaHead, current) where showref = inRepo $ Git.Command.pipeReadStrict [Param "show-ref"] - relevantrefs = map (Git.Ref . snd) . - nubBy uniqref . + relevantrefs headRef = addHead headRef . filter ourbranches . map (separate (== ' ')) . lines - uniqref (x, _) (y, _) = x == y + nubRefs = map (Git.Ref . snd) . nubBy (\(x, _) (y, _) -> x == y) ourbranchend = '/' : show Annex.Branch.name ourbranches (_, b) = not (ourbranchend `isSuffixOf` b) && not ("refs/synced/" `isPrefixOf` b) + addHead headRef refs = case headRef of + -- if HEAD diverges from all branches (except the branch it + -- points to), run the actions on staged keys (and keys + -- that are only present in the work tree if the repo is + -- non bare) + (Just (Git.Ref x), Just (Git.Ref b)) + | all (\(x',b') -> x /= x' || b == b') refs -> + Git.Ref.headRef + : nubRefs (filter ((/= x) . fst) refs) + _ -> nubRefs refs {- Runs an action on keys referenced in the given Git reference which - differ from those referenced in the index. -} withKeysReferencedInGitRef :: (Key -> Annex ()) -> Git.Ref -> Annex () withKeysReferencedInGitRef a ref = do showAction $ "checking " ++ Git.Ref.describe ref - (ts, clean) <- inRepo $ DiffTree.diffIndex ref - forM_ ts $ \t -> - mapM_ (`process` t) [DiffTree.dstsha, DiffTree.srcsha] + bare <- isBareRepo + (ts,clean) <- inRepo $ if bare + then DiffTree.diffIndex ref + else DiffTree.diffWorkTree ref + let lookAtWorkingTree = not bare && ref == Git.Ref.headRef + forM_ ts $ tKey lookAtWorkingTree >=> maybe noop a liftIO $ void clean where - -- the key will be Nothing for the nullSha - process getsha = catObject . getsha >=> - encodeW8 . L.unpack *>=> - fileKey . takeFileName *>=> - maybe noop a + tKey True = Backend.lookupFile . DiffTree.file >=*> + fmap fst + tKey False = catFile ref . DiffTree.file >=*> + fileKey . takeFileName . encodeW8 . L.unpack {- Looks in the specified directory for bad/tmp keys, and returns a list - of those that might still have value, or might be stale and removable. diff --git a/Git/DiffTree.hs b/Git/DiffTree.hs index 8f85fcc34..62330612c 100644 --- a/Git/DiffTree.hs +++ b/Git/DiffTree.hs @@ -10,6 +10,7 @@ module Git.DiffTree ( diffTree, diffTreeRecursive, diffIndex, + diffWorkTree, ) where import Numeric @@ -44,12 +45,23 @@ diffTreeRecursive src dst = getdiff (Param "diff-tree") {- Diffs between a tree and the index. Does nothing if there is not yet a - commit in the repository. -} diffIndex :: Ref -> Repo -> IO ([DiffTreeItem], IO Bool) -diffIndex ref repo = do +diffIndex ref = diffIndex' ref [Param "--cached"] + +{- Diffs between a tree and the working tree. Does nothing if there is not + - yet a commit in the repository, of if the repository is bare. -} +diffWorkTree :: Ref -> Repo -> IO ([DiffTreeItem], IO Bool) +diffWorkTree ref repo = + ifM (Git.Ref.headExists repo) + ( diffIndex' ref [] repo + , return ([], return True) + ) + +diffIndex' :: Ref -> [CommandParam] -> Repo -> IO ([DiffTreeItem], IO Bool) +diffIndex' ref params repo = ifM (Git.Ref.headExists repo) ( getdiff (Param "diff-index") - [ Param "--cached" - , Param $ show ref - ] repo + ( params ++ [Param $ show ref] ) + repo , return ([], return True) ) @@ -598,6 +598,26 @@ test_unused env = "git-annex unused/dropunused" ~: intmpclonerepoInDirect env $ removeFile "unusedunstagedfile" checkunused [unusedfilekey] "with unstaged link deleted" + -- unused used to miss symlinks that were deleted or modified + -- manually, but commited as such. + writeFile "unusedfile" "unusedcontent" + git_annex env "add" ["unusedfile"] @? "add of unusedfile failed" + boolSystem "git" [Param "add", File "unusedfile"] @? "git add failed" + unusedfilekey' <- annexeval $ findkey "unusedfile" + checkunused [] "with staged deleted link" + boolSystem "git" [Params "rm -qf", File "unusedfile"] @? "git rm failed" + checkunused [unusedfilekey'] "with staged link deleted" + + -- unused used to miss symlinks that were deleted or modified + -- manually, but not staged as such. + writeFile "unusedfile" "unusedcontent" + git_annex env "add" ["unusedfile"] @? "add of unusedfile failed" + boolSystem "git" [Param "add", File "unusedfile"] @? "git add failed" + unusedfilekey'' <- annexeval $ findkey "unusedfile" + checkunused [] "with unstaged deleted link" + removeFile "unusedfile" + checkunused [unusedfilekey''] "with unstaged link deleted" + where checkunused expectedkeys desc = do git_annex env "unused" [] @? "unused failed" |