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 cad8824852
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.
This commit is contained in:
Joey Hess 2012-02-13 23:42:44 -04:00
parent d35a8d85b5
commit cbaebf538a
16 changed files with 143 additions and 99 deletions

View file

@ -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
cwd <- getCurrentDirectory
(_, r) <- pipeBoth "git" (toCommand params) $
join "\0" $ input cwd
return $ zip files $ map attrvalue $ lines r
where
params = gitCommandLine
[ Param "check-attr"
, Param attr
, Params "-z --stdin"
] repo
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
(pid, from, to) <- hPipeBoth "git" $ toCommand $
gitCommandLine params repo
return (pid, from, to, attrs, cwd)
where
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 ++ ": "