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.
76 lines
2.1 KiB
Haskell
76 lines
2.1 KiB
Haskell
{- git cat-file interface
|
|
-
|
|
- Copyright 2011 Joey Hess <joey@kitenet.net>
|
|
-
|
|
- Licensed under the GNU GPL version 3 or higher.
|
|
-}
|
|
|
|
module Git.CatFile (
|
|
CatFileHandle,
|
|
catFileStart,
|
|
catFileStop,
|
|
catFile,
|
|
catObject,
|
|
catObjectDetails,
|
|
) where
|
|
|
|
import System.IO
|
|
import qualified Data.ByteString as S
|
|
import qualified Data.ByteString.Lazy as L
|
|
|
|
import Common
|
|
import Git
|
|
import Git.Sha
|
|
import Git.Command
|
|
import Git.Types
|
|
import Git.FilePath
|
|
import qualified Utility.CoProcess as CoProcess
|
|
|
|
type CatFileHandle = CoProcess.CoProcessHandle
|
|
|
|
catFileStart :: Repo -> IO CatFileHandle
|
|
catFileStart = CoProcess.rawMode <=< gitCoProcessStart True
|
|
[ Param "cat-file"
|
|
, Param "--batch"
|
|
]
|
|
|
|
catFileStop :: CatFileHandle -> IO ()
|
|
catFileStop = CoProcess.stop
|
|
|
|
{- Reads a file from a specified branch. -}
|
|
catFile :: CatFileHandle -> Branch -> FilePath -> IO L.ByteString
|
|
catFile h branch file = catObject h $ Ref $
|
|
show branch ++ ":" ++ toInternalGitPath file
|
|
|
|
{- Uses a running git cat-file read the content of an object.
|
|
- Objects that do not exist will have "" returned. -}
|
|
catObject :: CatFileHandle -> Ref -> IO L.ByteString
|
|
catObject h object = maybe L.empty fst <$> catObjectDetails h object
|
|
|
|
{- Gets both the content of an object, and its Sha. -}
|
|
catObjectDetails :: CatFileHandle -> Ref -> IO (Maybe (L.ByteString, Sha))
|
|
catObjectDetails h object = CoProcess.query h send receive
|
|
where
|
|
send to = hPutStrLn to $ show object
|
|
receive from = do
|
|
header <- hGetLine from
|
|
case words header of
|
|
[sha, objtype, size]
|
|
| length sha == shaSize &&
|
|
isJust (readObjectType objtype) ->
|
|
case reads size of
|
|
[(bytes, "")] -> readcontent bytes from sha
|
|
_ -> dne
|
|
| otherwise -> dne
|
|
_
|
|
| header == show object ++ " missing" -> dne
|
|
| otherwise -> error $ "unknown response from git cat-file " ++ show (header, object)
|
|
readcontent bytes from sha = do
|
|
content <- S.hGet from bytes
|
|
eatchar '\n' from
|
|
return $ Just (L.fromChunks [content], Ref sha)
|
|
dne = return Nothing
|
|
eatchar expected from = do
|
|
c <- hGetChar from
|
|
when (c /= expected) $
|
|
error $ "missing " ++ (show expected) ++ " from git cat-file"
|