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
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
|
{- git-update-index library
-
- Copyright 2011-2022 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
{-# LANGUAGE BangPatterns, OverloadedStrings, CPP #-}
module Git.UpdateIndex (
Streamer,
pureStreamer,
streamUpdateIndex,
streamUpdateIndex',
withUpdateIndex,
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
import qualified Data.ByteString as S
import qualified Data.ByteString.Lazy as L
import Control.Monad.IO.Class
{- Streamers are passed a callback and should feed it lines in the form
- read by update-index, and generated by ls-tree. -}
type Streamer = (L.ByteString -> IO ()) -> IO ()
{- A streamer with a precalculated value. -}
pureStreamer :: L.ByteString -> Streamer
pureStreamer !s = \streamer -> streamer s
{- Streams content into update-index from a list of Streamers. -}
streamUpdateIndex :: Repo -> [Streamer] -> IO ()
streamUpdateIndex repo as = withUpdateIndex repo $ \h ->
forM_ as $ streamUpdateIndex' h
data UpdateIndexHandle = UpdateIndexHandle Handle
streamUpdateIndex' :: UpdateIndexHandle -> Streamer -> IO ()
streamUpdateIndex' (UpdateIndexHandle h) a = a $ \s -> do
L.hPutStr h s
L.hPutStr h "\0"
withUpdateIndex :: (MonadIO m, MonadMask m) => Repo -> (UpdateIndexHandle -> m a) -> m a
withUpdateIndex repo a = bracket setup cleanup go
where
params = map Param ["update-index", "-z", "--index-info"]
setup = liftIO $ createProcess $
(gitCreateProcess params repo)
{ std_in = CreatePipe }
go p = do
r <- a (UpdateIndexHandle (stdinHandle p))
liftIO $ do
hClose (stdinHandle p)
void $ checkSuccessProcess (processHandle p)
return r
cleanup = liftIO . cleanupProcess
{- 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", decodeBS 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", decodeBS 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 -> L.ByteString
updateIndexLine sha treeitemtype file = L.fromStrict $
fmtTreeItemType treeitemtype
<> " blob "
<> fromRef' sha
<> "\t"
<> indexPath file
stageFile :: Sha -> TreeItemType -> RawFilePath -> 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 :: RawFilePath -> Repo -> IO Streamer
unstageFile file repo = do
p <- toTopFilePath file repo
return $ unstageFile' p
unstageFile' :: TopFilePath -> Streamer
unstageFile' p = pureStreamer $ L.fromStrict $
"0 "
<> fromRef' deleteSha
<> "\t"
<> indexPath p
{- A streamer that adds a symlink to the index. -}
stageSymlink :: RawFilePath -> 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.
-
- The action is passed a callback that it can use to send filenames to
- update-index. Sending Nothing will wait for update-index to finish
- updating the index.
-}
refreshIndex :: (MonadIO m, MonadMask m) => Repo -> ((Maybe RawFilePath -> IO ()) -> m ()) -> m ()
refreshIndex repo feeder = bracket
(liftIO $ createProcess p)
(liftIO . cleanupProcess)
go
where
params =
[ Param "update-index"
, Param "-q"
, Param "--refresh"
, Param "-z"
, Param "--stdin"
]
p = (gitCreateProcess params repo)
{ std_in = CreatePipe }
go (Just h, _, _, pid) = do
let closer = do
hClose h
forceSuccessProcess p pid
feeder $ \case
Just f -> S.hPut h (S.snoc f 0)
Nothing -> closer
liftIO $ closer
go _ = error "internal"
|
