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:
parent
d35a8d85b5
commit
cbaebf538a
16 changed files with 143 additions and 99 deletions
|
@ -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 ++ ": "
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue