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
134
135
136
137
138
139
140
141
142
143
144
145
146
|
{- git-update-index library
-
- Copyright 2011-2018 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU GPL version 3 or higher.
-}
{-# LANGUAGE BangPatterns, CPP #-}
module Git.UpdateIndex (
Streamer,
pureStreamer,
streamUpdateIndex,
streamUpdateIndex',
startUpdateIndex,
stopUpdateIndex,
lsTree,
lsSubTree,
updateIndexLine,
stageFile,
unstageFile,
stageSymlink,
stageDiffTreeItem,
refreshIndex,
) where
import Common
import Git
import Git.Types
import Git.Command
import Git.FilePath
import Git.Sha
import qualified Git.DiffTreeItem as Diff
{- Streamers are passed a callback and should feed it lines in the form
- read by update-index, and generated by ls-tree. -}
type Streamer = (String -> IO ()) -> IO ()
{- A streamer with a precalculated value. -}
pureStreamer :: String -> Streamer
pureStreamer !s = \streamer -> streamer s
{- Streams content into update-index from a list of Streamers. -}
streamUpdateIndex :: Repo -> [Streamer] -> IO ()
streamUpdateIndex repo as = bracket (startUpdateIndex repo) stopUpdateIndex $
(\h -> forM_ as $ streamUpdateIndex' h)
data UpdateIndexHandle = UpdateIndexHandle ProcessHandle Handle
streamUpdateIndex' :: UpdateIndexHandle -> Streamer -> IO ()
streamUpdateIndex' (UpdateIndexHandle _ h) a = a $ \s -> do
hPutStr h s
hPutStr h "\0"
startUpdateIndex :: Repo -> IO UpdateIndexHandle
startUpdateIndex repo = do
(Just h, _, _, p) <- createProcess (gitCreateProcess params repo)
{ std_in = CreatePipe }
return $ UpdateIndexHandle p h
where
params = map Param ["update-index", "-z", "--index-info"]
stopUpdateIndex :: UpdateIndexHandle -> IO Bool
stopUpdateIndex (UpdateIndexHandle p h) = do
hClose h
checkSuccessProcess p
{- A streamer that adds the current tree for a ref. Useful for eg, copying
- and modifying branches. -}
lsTree :: Ref -> Repo -> Streamer
lsTree (Ref x) repo streamer = do
(s, cleanup) <- pipeNullSplit params repo
mapM_ streamer s
void $ cleanup
where
params = map Param ["ls-tree", "-z", "-r", "--full-tree", x]
lsSubTree :: Ref -> FilePath -> Repo -> Streamer
lsSubTree (Ref x) p repo streamer = do
(s, cleanup) <- pipeNullSplit params repo
mapM_ streamer s
void $ cleanup
where
params = map Param ["ls-tree", "-z", "-r", "--full-tree", x, p]
{- Generates a line suitable to be fed into update-index, to add
- a given file with a given sha. -}
updateIndexLine :: Sha -> TreeItemType -> TopFilePath -> String
updateIndexLine sha treeitemtype file = concat
[ fmtTreeItemType treeitemtype
, " blob "
, fromRef sha
, "\t"
, indexPath file
]
stageFile :: Sha -> TreeItemType -> FilePath -> Repo -> IO Streamer
stageFile sha treeitemtype file repo = do
p <- toTopFilePath file repo
return $ pureStreamer $ updateIndexLine sha treeitemtype p
{- A streamer that removes a file from the index. -}
unstageFile :: FilePath -> Repo -> IO Streamer
unstageFile file repo = do
p <- toTopFilePath file repo
return $ unstageFile' p
unstageFile' :: TopFilePath -> Streamer
unstageFile' p = pureStreamer $ "0 " ++ fromRef nullSha ++ "\t" ++ indexPath p
{- A streamer that adds a symlink to the index. -}
stageSymlink :: FilePath -> Sha -> Repo -> IO Streamer
stageSymlink file sha repo = do
!line <- updateIndexLine
<$> pure sha
<*> pure TreeSymlink
<*> toTopFilePath file repo
return $ pureStreamer line
{- A streamer that applies a DiffTreeItem to the index. -}
stageDiffTreeItem :: Diff.DiffTreeItem -> Streamer
stageDiffTreeItem d = case toTreeItemType (Diff.dstmode d) of
Nothing -> unstageFile' (Diff.file d)
Just t -> pureStreamer $ updateIndexLine (Diff.dstsha d) t (Diff.file d)
indexPath :: TopFilePath -> InternalGitPath
indexPath = toInternalGitPath . getTopFilePath
{- Refreshes the index, by checking file stat information. -}
refreshIndex :: Repo -> ((FilePath -> IO ()) -> IO ()) -> IO Bool
refreshIndex repo feeder = do
(Just h, _, _, p) <- createProcess (gitCreateProcess params repo)
{ std_in = CreatePipe }
feeder $ \f -> do
hPutStr h f
hPutStr h "\0"
hFlush h
hClose h
checkSuccessProcess p
where
params =
[ Param "update-index"
, Param "-q"
, Param "--refresh"
, Param "-z"
, Param "--stdin"
]
|
