rework git check-attr interface

Now gitattributes are looked up, efficiently, in only the places that
really need them, using the same approach used for cat-file.

The old CheckAttr code seemed very fragile, in the way it streamed files
through git check-attr.
I actually found that cad8824852aa0623dc41eac02a9e2bae47d88ec4
was still deadlocking with ghc 7.4, at the end of adding a lot of files.
This should fix that problem, and avoid future ones.

The best part is that this removes withAttrFilesInGit and withNumCopies,
which were complicated Seek methods, as well as simplfying the types
for several other Seek methods that had a Backend tupled in.

1 files changed, 40 insertions, 16 deletions

diff --git a/Git/CheckAttr.hs b/Git/CheckAttr.hs
index 5c747a951..669a9c54e 100644
--- a/Git/CheckAttr.hs
+++ b/Git/CheckAttr.hs
@@ -1,6 +1,6 @@
 {- git check-attr interface
  -
- - Copyright 2010, 2011 Joey Hess <joey@kitenet.net>
+ - Copyright 2010-2012 Joey Hess <joey@kitenet.net>
  -
  - Licensed under the GNU GPL version 3 or higher.
  -}
@@ -12,20 +12,44 @@ import Git
 import Git.Command
 import qualified Git.Version
 
-{- Efficiently looks up a gitattributes value for each file in a list. -}
-lookup :: String -> [FilePath] -> Repo -> IO [(FilePath, String)]
-lookup attr files repo = do
+type CheckAttrHandle = (PipeHandle, Handle, Handle, [Attr], String)
+
+type Attr = String
+
+{- Starts git check-attr running to look up the specified gitattributes
+ - values and return a handle.  -}
+checkAttrStart :: [Attr] -> Repo -> IO CheckAttrHandle
+checkAttrStart attrs repo = do
 	cwd <- getCurrentDirectory
-	(_, r) <- pipeBoth "git" (toCommand params) $
-		join "\0" $ input cwd
-	return $ zip files $ map attrvalue $ lines r
+	(pid, from, to) <- hPipeBoth "git" $ toCommand $
+		gitCommandLine params repo
+	return (pid, from, to, attrs, cwd)
 	where
-		params = gitCommandLine 
-				[ Param "check-attr"
-				, Param attr
-				, Params "-z --stdin"
-				] repo
+		params =
+			[ Param "check-attr" ]
+			++ map Param attrs ++
+			[ Params "-z --stdin" ]
 
+{- Stops git check-attr. -}
+checkAttrStop :: CheckAttrHandle -> IO ()
+checkAttrStop (pid, from, to, _, _) = do
+	hClose to
+	hClose from
+	forceSuccess pid
+
+{- Gets an attribute of a file. -}
+checkAttr :: CheckAttrHandle -> Attr -> FilePath -> IO String
+checkAttr (_, from, to, attrs, cwd) want file = do
+	hPutStr to $ file' ++ "\0"
+	hFlush to
+	pairs <- forM attrs $ \attr -> do
+		l <- hGetLine from
+		return (attr, attrvalue attr l)
+	let vals = map snd $ filter (\(attr, _) -> attr == want) pairs
+	case vals of
+		[v] -> return v
+		_ -> error $ "unable to determine " ++ want ++ " attribute of " ++ file
+	where
 		{- Before git 1.7.7, git check-attr worked best with
 		 - absolute filenames; using them worked around some bugs
 		 - with relative filenames.
@@ -34,10 +58,10 @@ lookup attr files repo = do
 		 - filenames, and the bugs that necessitated them were fixed,
 		 - so use relative filenames. -}
 		oldgit = Git.Version.older "1.7.7"
-		input cwd
-			| oldgit = map (absPathFrom cwd) files
-			| otherwise = map (relPathDirToFile cwd . absPathFrom cwd) files
-		attrvalue l = end bits !! 0
+		file'
+			| oldgit = absPathFrom cwd file
+			| otherwise = relPathDirToFile cwd $ absPathFrom cwd file
+		attrvalue attr l = end bits !! 0
 			where
 				bits = split sep l
 				sep = ": " ++ attr ++ ": "