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
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
|
{- management of the git-annex branch
-
- Copyright 2011 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Branch (
create,
update,
get,
change,
commit,
files
) where
import Control.Monad (unless, when, liftM)
import Control.Monad.State (liftIO)
import System.FilePath
import System.Directory
import Data.String.Utils
import System.Cmd.Utils
import Data.Maybe
import Data.List
import System.IO
import System.Posix.IO
import System.Posix.Process
import Types.BranchState
import qualified GitRepo as Git
import qualified GitUnionMerge
import qualified Annex
import Utility
import Types
import Messages
{- Name of the branch that is used to store git-annex's information. -}
name :: String
name = "git-annex"
{- Fully qualified name of the branch. -}
fullname :: String
fullname = "refs/heads/" ++ name
shortref :: String -> String
shortref = remove "refs/heads/" . remove "refs/remotes/"
where
remove prefix s
| prefix `isPrefixOf` s = drop (length prefix) s
| otherwise = s
{- A separate index file for the branch. -}
index :: Git.Repo -> FilePath
index g = Git.workTree g </> Git.gitDir g </> "index." ++ name
{- Populates the branch's index file with the current branch contents.
-
- Usually, this is only done when the index doesn't yet exist, and
- the index is used to build up changes to be commited to the branch.
-}
genIndex :: Git.Repo -> IO ()
genIndex g = do
ls <- Git.pipeNullSplit g $
map Param ["ls-tree", "-z", "-r", "--full-tree", fullname]
forceSuccess =<< Git.pipeWrite g
(map Param ["update-index", "-z", "--index-info"])
(join "\0" ls)
{- Runs an action using the branch's index file. -}
withIndex :: Annex a -> Annex a
withIndex = withIndex' False
withIndex' :: Bool -> Annex a -> Annex a
withIndex' bootstrapping a = do
g <- Annex.gitRepo
let f = index g
reset <- liftIO $ Git.useIndex f
unless bootstrapping $ do
e <- liftIO $ doesFileExist f
unless e $ liftIO $ genIndex g
r <- a
liftIO reset
return r
withIndexUpdate :: Annex a -> Annex a
withIndexUpdate a = update >> withIndex a
getState :: Annex BranchState
getState = Annex.getState Annex.branchstate
setState :: BranchState -> Annex ()
setState state = Annex.changeState $ \s -> s { Annex.branchstate = state }
setCache :: FilePath -> String -> Annex ()
setCache file content = do
state <- getState
setState state { cachedFile = Just file, cachedContent = content }
setCacheChanged :: FilePath -> String -> Annex ()
setCacheChanged file content = do
state <- getState
setState state { cachedFile = Just file, cachedContent = content, branchChanged = True }
invalidateCache :: Annex ()
invalidateCache = do
state <- getState
setState state { cachedFile = Nothing, cachedContent = "" }
getCache :: FilePath -> Annex (Maybe String)
getCache file = getState >>= handle
where
handle state
| cachedFile state == Just file =
return $ Just $ cachedContent state
| otherwise = return Nothing
{- Creates the branch, if it does not already exist. -}
create :: Annex ()
create = do
exists <- refexists fullname
unless exists $ do
g <- Annex.gitRepo
inorigin <- refexists origin
if inorigin
then liftIO $ Git.run g "branch" [Param name, Param origin]
else withIndex' True $
liftIO $ GitUnionMerge.commit g "branch created" fullname []
where
origin = "origin/" ++ name
refexists ref = do
g <- Annex.gitRepo
liftIO $ Git.runBool g "show-ref"
[Param "--verify", Param "-q", Param ref]
{- Commits any staged changes to the branch. -}
commit :: String -> Annex ()
commit message = do
state <- getState
when (branchChanged state) $ do
g <- Annex.gitRepo
withIndex $ liftIO $
GitUnionMerge.commit g message fullname [fullname]
{- Ensures that the branch is up-to-date; should be called before
- data is read from it. Runs only once per git-annex run. -}
update :: Annex ()
update = do
state <- Annex.getState Annex.branchstate
unless (branchUpdated state) $ withIndex $ do
g <- Annex.gitRepo
r <- liftIO $ Git.pipeRead g [Param "show-ref", Param name]
let refs = map (last . words) (lines r)
updated <- catMaybes `liftM` mapM updateRef refs
unless (null updated) $ liftIO $
GitUnionMerge.commit g "update" fullname
(fullname:updated)
Annex.changeState $ \s -> s { Annex.branchstate = state { branchUpdated = True } }
invalidateCache
{- Ensures that a given ref has been merged into the index. -}
updateRef :: String -> Annex (Maybe String)
updateRef ref
| ref == fullname = return Nothing
| otherwise = do
g <- Annex.gitRepo
-- checking with log to see if there have been changes
-- is less expensive than always merging
diffs <- liftIO $ Git.pipeRead g [
Param "log",
Param (name++".."++ref),
Params "--oneline -n1"
]
if (null diffs)
then return Nothing
else do
showSideAction $ "merging " ++ shortref ref ++ " into " ++ name ++ "..."
-- By passing only one ref, it is actually
-- merged into the index, preserving any
-- changes that may already be staged.
--
-- However, any changes in the git-annex
-- branch that are *not* reflected in the
-- index will be removed. So, documentation
-- advises users not to directly modify the
-- branch.
liftIO $ GitUnionMerge.merge g [ref]
return $ Just ref
{- Stages the content of a file into the branch's index. -}
change :: FilePath -> String -> Annex ()
change file content = do
g <- Annex.gitRepo
sha <- liftIO $ Git.hashObject g content
withIndex $ liftIO $ Git.run g "update-index"
[ Param "--add", Param "--cacheinfo", Param "100644",
Param sha, File file]
setCacheChanged file content
{- Gets the content of a file on the branch, or content staged in the index
- if it's newer. Returns an empty string if the file didn't exist yet. -}
get :: FilePath -> Annex String
get file = do
cached <- getCache file
case cached of
Just content -> return content
Nothing -> withIndexUpdate $ do
g <- Annex.gitRepo
content <- liftIO $ catch (cat g) (const $ return "")
setCache file content
return content
where
cat g = cmdOutput "git" $ toCommand $ Git.gitCommandLine g
[Param "cat-file", Param "blob", Param $ ':':file]
{- Runs a command, returning its output, ignoring nonzero exit
- status, and discarding stderr. -}
cmdOutput :: FilePath -> [String] -> IO String
cmdOutput cmd params = do
pipepair <- createPipe
let callfunc _ = do
closeFd (snd pipepair)
h <- fdToHandle (fst pipepair)
x <- hGetContentsStrict h
hClose h
return $! x
pid <- pOpen3Raw Nothing (Just (snd pipepair)) Nothing cmd params
(closeFd (fst pipepair) >> closeFd stdError)
retval <- callfunc $! pid
let rv = seq retval retval
_ <- getProcessStatus True False pid
return rv
{- Lists all files on the branch. -}
files :: Annex [FilePath]
files = withIndexUpdate $ do
g <- Annex.gitRepo
liftIO $ Git.pipeNullSplit g
[Params "ls-tree --name-only -r -z", Param fullname]
|
