91c4dcfc69
Fuzz tests have shown that git cat-file --batch sometimes stops running. It's not yet known why (no error message; repo seems ok). But this is something we can deal with in the CoProcess framework, since all 3 types of long-running git processes should be restartable if they fail. Note that, as implemented, only IO errors are caught. So an error thrown by the reveiver, when it sees something that is not valid output from git cat-file (etc) will not cause a restart. I don't want it to retry if git commands change their output or are just outputting garbage. This does mean that if the command did a partial output and crashed in the middle, it would still not be restarted. There is currently no guard against restarting a command repeatedly, if, for example, it crashes repeatedly on startup.
64 lines
1.9 KiB
Haskell
64 lines
1.9 KiB
Haskell
{- git check-attr interface
|
|
-
|
|
- Copyright 2010-2012 Joey Hess <joey@kitenet.net>
|
|
-
|
|
- Licensed under the GNU GPL version 3 or higher.
|
|
-}
|
|
|
|
module Git.CheckAttr where
|
|
|
|
import Common
|
|
import Git
|
|
import Git.Command
|
|
import qualified Git.Version
|
|
import qualified Utility.CoProcess as CoProcess
|
|
|
|
type CheckAttrHandle = (CoProcess.CoProcessHandle, [Attr], String)
|
|
|
|
type Attr = String
|
|
|
|
{- Starts git check-attr running to look up the specified gitattributes
|
|
- values and returns a handle. -}
|
|
checkAttrStart :: [Attr] -> Repo -> IO CheckAttrHandle
|
|
checkAttrStart attrs repo = do
|
|
cwd <- getCurrentDirectory
|
|
h <- CoProcess.rawMode =<< gitCoProcessStart True params repo
|
|
return (h, attrs, cwd)
|
|
where
|
|
params =
|
|
[ Param "check-attr"
|
|
, Params "-z --stdin"
|
|
] ++ map Param attrs ++
|
|
[ Param "--" ]
|
|
|
|
checkAttrStop :: CheckAttrHandle -> IO ()
|
|
checkAttrStop (h, _, _) = CoProcess.stop h
|
|
|
|
{- Gets an attribute of a file. -}
|
|
checkAttr :: CheckAttrHandle -> Attr -> FilePath -> IO String
|
|
checkAttr (h, attrs, cwd) want file = do
|
|
pairs <- CoProcess.query h send receive
|
|
let vals = map snd $ filter (\(attr, _) -> attr == want) pairs
|
|
case vals of
|
|
[v] -> return v
|
|
_ -> error $ "unable to determine " ++ want ++ " attribute of " ++ file
|
|
where
|
|
send to = hPutStr to $ file' ++ "\0"
|
|
receive from = forM attrs $ \attr -> do
|
|
l <- hGetLine from
|
|
return (attr, attrvalue attr l)
|
|
{- Before git 1.7.7, git check-attr worked best with
|
|
- absolute filenames; using them worked around some bugs
|
|
- with relative filenames.
|
|
-
|
|
- With newer git, git check-attr chokes on some absolute
|
|
- filenames, and the bugs that necessitated them were fixed,
|
|
- so use relative filenames. -}
|
|
oldgit = Git.Version.older "1.7.7"
|
|
file'
|
|
| oldgit = absPathFrom cwd file
|
|
| otherwise = relPathDirToFile cwd $ absPathFrom cwd file
|
|
attrvalue attr l = end bits !! 0
|
|
where
|
|
bits = split sep l
|
|
sep = ": " ++ attr ++ ": "
|