make unused check branches and tags too

needs time and space optimisation

4 files changed, 41 insertions, 7 deletions

diff --git a/Backend.hs b/Backend.hs
index d12913985..ca822de5c 100644
--- a/Backend.hs
+++ b/Backend.hs
@@ -17,6 +17,7 @@ module Backend (
 ) where
 
 import Control.Monad.State (liftIO, when)
+import Control.Applicative
 import System.IO.Error (try)
 import System.FilePath
 import System.Posix.Files
@@ -86,9 +87,7 @@ lookupFile file = do
 		Left _ -> return Nothing
 		Right l -> makekey l
 	where
-		getsymlink = do
-			l <- readSymbolicLink file
-			return $ takeFileName l
+		getsymlink = takeFileName <$> readSymbolicLink file
 		makekey l = maybe (return Nothing) (makeret l) (fileKey l)
 		makeret l k =
 			case maybeLookupBackendName bname of
diff --git a/Command/Unused.hs b/Command/Unused.hs
index f62e68c30..e629f9fb9 100644
--- a/Command/Unused.hs
+++ b/Command/Unused.hs
@@ -15,6 +15,8 @@ import qualified Data.Set as S
 import Data.Maybe
 import System.FilePath
 import System.Directory
+import Data.List
+import Control.Applicative
 
 import Command
 import Types
@@ -22,12 +24,17 @@ import Content
 import Messages
 import Locations
 import Utility
+import Utility.FileMode
+import Utility.SafeCommand
 import LocationLog
 import qualified Annex
 import qualified Git
 import qualified Git.LsFiles as LsFiles
+import qualified Git.LsTree as LsTree
 import qualified Backend
 import qualified Remote
+import qualified Branch
+import CatFile
 
 command :: [Command]
 command = [repoCommand "unused" paramNothing seek
@@ -173,7 +180,29 @@ getKeysReferenced = do
 	g <- Annex.gitRepo
 	files <- liftIO $ LsFiles.inRepo g [Git.workTree g]
 	keypairs <- mapM Backend.lookupFile files
-	return $ map fst $ catMaybes keypairs
+	ingit <- getKeysReferencedInGit
+	return $ concat [ingit, map fst $ catMaybes keypairs]
+
+{- List of keys referenced by symlinks in all git branches and tags. -}
+getKeysReferencedInGit :: Annex [Key]
+getKeysReferencedInGit = do
+	g <- Annex.gitRepo
+	c <- liftIO $ Git.pipeRead g [Param "show-ref"]
+	-- Skip the git-annex branches, and get all other unique refs.
+	let refs = nub $ map head $ filter ourbranches $ map words $ lines c
+	concat <$> mapM (\r -> findkeys r [] =<< liftIO (LsTree.lsTree g r)) refs
+	where
+		ourbranchend = "/" ++ Branch.name
+		ourbranches ws = not $ ourbranchend `isSuffixOf` last ws
+		findkeys _ c [] = return c
+		findkeys ref c (l:ls) = do
+			if isSymLink (LsTree.mode l)
+				then do
+					content <- catFile ref $ LsTree.file l
+					case fileKey (takeFileName content) of
+						Nothing -> findkeys ref c ls
+						Just k -> findkeys ref (k:c) ls
+				else findkeys ref c ls
 
 {- 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/LsTree.hs b/Git/LsTree.hs
index 2220cfc50..4a6c509f9 100644
--- a/Git/LsTree.hs
+++ b/Git/LsTree.hs
@@ -6,6 +6,7 @@
  -}
 
 module Git.LsTree (
+	TreeItem(..),
 	lsTree
 ) where
 
@@ -43,7 +44,8 @@ parseLsTree l = TreeItem m o s f
 		(o, past_o) = splitAt 4 $ space past_m
 		(s, past_s) = splitAt shaSize $ space past_o
 		f = decodeGitFile $ space past_s
-		space s@(sp:rest)
+		space (sp:rest)
 			| isSpace sp = rest
-			| otherwise = error $
-				"ls-tree parse error at '" ++ s ++ "' in " ++ l
+			| otherwise = parseerr
+		space [] = parseerr
+		parseerr = "ls-tree parse error: " ++ l
diff --git a/Utility/FileMode.hs b/Utility/FileMode.hs
index f5b018c84..6c1c06e82 100644
--- a/Utility/FileMode.hs
+++ b/Utility/FileMode.hs
@@ -30,3 +30,7 @@ allowWrite :: FilePath -> IO ()
 allowWrite f = do
 	s <- getFileStatus f
 	setFileMode f $ fileMode s `unionFileModes` ownerWriteMode
+
+{- Checks if a file mode indicates it's a symlink. -}
+isSymLink :: FileMode -> Bool
+isSymLink mode = symbolicLinkMode `intersectFileModes` mode == symbolicLinkMode