1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
|
{- git cat-file interface
-
- Copyright 2011, 2013 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Git.CatFile (
CatFileHandle,
catFileStart,
catFileStop,
catFile,
catTree,
catObject,
catObjectDetails,
) where
import System.IO
import qualified Data.ByteString as S
import qualified Data.ByteString.Lazy as L
import Data.Digest.Pure.SHA
import Data.Char
import System.Process (std_out, std_err)
import Numeric
import System.Posix.Types
import Common
import Git
import Git.Sha
import Git.Command
import Git.Types
import Git.FilePath
import qualified Utility.CoProcess as CoProcess
data CatFileHandle = CatFileHandle CoProcess.CoProcessHandle Repo
catFileStart :: Repo -> IO CatFileHandle
catFileStart repo = do
coprocess <- CoProcess.rawMode =<< gitCoProcessStart True
[ Param "cat-file"
, Param "--batch"
] repo
return $ CatFileHandle coprocess repo
catFileStop :: CatFileHandle -> IO ()
catFileStop (CatFileHandle p _) = CoProcess.stop p
{- 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 (CatFileHandle hdl repo) object = CoProcess.query hdl send receive
where
query = show object
send to = hPutStrLn to query
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 ->
if any isSpace query
then fallback
else 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"
{- Work around a bug in git 1.8.4 rc0 which broke it for filenames
- containing spaces. http://bugs.debian.org/718517
- Slow! Also can use a lot of memory, if the object is large. -}
fallback = do
let p = gitCreateProcess
[ Param "cat-file"
, Param "-p"
, Param query
] repo
(_, Just h, _, pid) <- withNullHandle $ \h ->
createProcess p
{ std_out = CreatePipe
, std_err = UseHandle h
}
fileEncoding h
content <- L.hGetContents h
let sha = (\s -> length s `seq` s) (showDigest $ sha1 content)
ok <- checkSuccessProcess pid
return $ if ok
then Just (content, Ref sha)
else Nothing
{- Gets a list of files and directories in a tree. (Not recursive.) -}
catTree :: CatFileHandle -> Ref -> IO [(FilePath, FileMode)]
catTree h treeref = go <$> catObjectDetails h treeref
where
go Nothing = []
go (Just (b, _)) = parsetree [] b
parsetree c b = case L.break (== 0) b of
(modefile, rest)
| L.null modefile -> c
| otherwise -> parsetree
(parsemodefile modefile:c)
(dropsha rest)
-- these 20 bytes after the NUL hold the file's sha
-- TODO: convert from raw form to regular sha
dropsha = L.drop 21
parsemodefile b =
let (modestr, file) = separate (== ' ') (encodeW8 $ L.unpack b)
in (file, readmode modestr)
readmode = fst . Prelude.head . readOct
|
