9290095fc2
In git, a Ref can be a Sha, or a Branch, or a Tag. I added type aliases for those. Note that this does not prevent mixing up of eg, refs and branches at the type level. Since git really doesn't care, except rare cases like git update-ref, or git tag -d, that seems ok for now. There's also a tree-ish, but let's just use Ref for it. A given Sha or Ref may or may not be a tree-ish, depending on the object type, so there seems no point in trying to represent it at the type level.
73 lines
1.9 KiB
Haskell
73 lines
1.9 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
|
|
) where
|
|
|
|
import Control.Monad.State
|
|
import System.Cmd.Utils
|
|
import System.IO
|
|
import qualified Data.ByteString.Char8 as S
|
|
import qualified Data.ByteString.Lazy.Char8 as L
|
|
|
|
import Git
|
|
import Utility.SafeCommand
|
|
|
|
type CatFileHandle = (PipeHandle, Handle, Handle)
|
|
|
|
{- Starts git cat-file running in batch mode in a repo and returns a handle. -}
|
|
catFileStart :: Repo -> IO CatFileHandle
|
|
catFileStart repo = hPipeBoth "git" $ toCommand $
|
|
Git.gitCommandLine [Param "cat-file", Param "--batch"] repo
|
|
|
|
{- Stops git cat-file. -}
|
|
catFileStop :: CatFileHandle -> IO ()
|
|
catFileStop (pid, from, to) = do
|
|
hClose to
|
|
hClose from
|
|
forceSuccess pid
|
|
|
|
{- Reads a file from a specified branch. -}
|
|
catFile :: CatFileHandle -> Branch -> FilePath -> IO L.ByteString
|
|
catFile h branch file = catObject h $ Ref $ show branch ++ ":" ++ 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 (_, from, to) object = do
|
|
hPutStrLn to $ show object
|
|
hFlush to
|
|
header <- hGetLine from
|
|
case words header of
|
|
[sha, objtype, size]
|
|
| length sha == Git.shaSize &&
|
|
validobjtype objtype -> handle size
|
|
| otherwise -> empty
|
|
_
|
|
| header == show object ++ " missing" -> empty
|
|
| otherwise -> error $ "unknown response from git cat-file " ++ header
|
|
where
|
|
handle size = case reads size of
|
|
[(bytes, "")] -> readcontent bytes
|
|
_ -> empty
|
|
readcontent bytes = do
|
|
content <- S.hGet from bytes
|
|
c <- hGetChar from
|
|
when (c /= '\n') $
|
|
error "missing newline from git cat-file"
|
|
return $ L.fromChunks [content]
|
|
empty = return L.empty
|
|
validobjtype t
|
|
| t == "blob" = True
|
|
| t == "commit" = True
|
|
| t == "tree" = True
|
|
| otherwise = False
|