summaryrefslogtreecommitdiff
path: root/Annex/Branch.hs
blob: c6db9decaf5bc68bf92da3d18a031aedc1464f0b (plain)
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
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
{- management of the git-annex branch
 -
 - Copyright 2011 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Annex.Branch (
	create,
	update,
	get,
	change,
	commit,
	files,
	refExists,
	hasOrigin,
	hasSomeBranch,
	name	
) where

import System.IO.Binary
import System.Exit
import qualified Data.ByteString.Lazy.Char8 as L

import Annex.Common
import Annex.Exception
import Types.BranchState
import qualified Git
import qualified Git.UnionMerge
import qualified Annex
import Annex.CatFile

type GitRef = String

{- Name of the branch that is used to store git-annex's information. -}
name :: GitRef
name = "git-annex"

{- Fully qualified name of the branch. -}
fullname :: GitRef
fullname = "refs/heads/" ++ name

{- Branch's name in origin. -}
originname :: GitRef
originname = "origin/" ++ name

{- A separate index file for the branch. -}
index :: Git.Repo -> FilePath
index g = gitAnnexDir g </> "index"

{- 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,
 - and merge in changes from other branches.
 -}
genIndex :: Git.Repo -> IO ()
genIndex g = Git.UnionMerge.ls_tree g fullname >>= Git.UnionMerge.update_index g

{- 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 <- gitRepo
	let f = index g

	bracketIO (Git.useIndex f) id $ do
		unlessM (liftIO $ doesFileExist f) $ do
			unless bootstrapping create
			liftIO $ createDirectoryIfMissing True $ takeDirectory f
			unless bootstrapping $ liftIO $ genIndex g
		a

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 }

invalidateCache :: Annex ()
invalidateCache = do
	state <- getState
	setState state { cachedFile = Nothing, cachedContent = "" }

getCache :: FilePath -> Annex (Maybe String)
getCache file = getState >>= go
	where
		go state
			| cachedFile state == Just file =
				return $ Just $ cachedContent state
			| otherwise = return Nothing

{- Creates the branch, if it does not already exist. -}
create :: Annex ()
create = unlessM hasBranch $ do
	g <- gitRepo
	e <- hasOrigin
	if e
		then liftIO $ Git.run g "branch" [Param name, Param originname]
		else withIndex' True $
			liftIO $ Git.commit g "branch created" fullname []

{- Stages the journal, and commits staged changes to the branch. -}
commit :: String -> Annex ()
commit message = do
	fs <- getJournalFiles
	when (not $ null fs) $ lockJournal $ do
		stageJournalFiles fs
		g <- gitRepo
		withIndex $ liftIO $ Git.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 <- getState
	unless (branchUpdated state) $ do
		-- check what needs updating before taking the lock
		fs <- getJournalFiles
		refs <- filterM checkref =<< siblingBranches
		unless (null fs && null refs) $ withIndex $ lockJournal $ do
			{- Before refs are merged into the index, it's
			 - important to first stage the journal into the
			 - index. Otherwise, any changes in the journal
			 - would later get staged, and might overwrite
			 - changes made during the merge.
			 -
			 - It would be cleaner to handle the merge by
			 - updating the journal, not the index, with changes
			 - from the branches.
			 -}
			unless (null fs) $ stageJournalFiles fs
			mapM_ mergeref refs
			g <- gitRepo
			liftIO $ Git.commit g "update" fullname (fullname:refs)
			Annex.changeState $ \s -> s { Annex.branchstate = state { branchUpdated = True } }
			invalidateCache
	where
		checkref ref = do
			g <- 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"
				]
			return $ not $ L.null diffs
		mergeref ref = do
			showSideAction $ "merging " ++
				Git.refDescribe 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.
			 -}
			g <- gitRepo
			liftIO $ Git.UnionMerge.merge g [ref]
			return $ Just ref

{- Checks if a git ref exists. -}
refExists :: GitRef -> Annex Bool
refExists ref = do
	g <- gitRepo
	liftIO $ Git.runBool g "show-ref"
		[Param "--verify", Param "-q", Param ref]

{- Does the main git-annex branch exist? -}
hasBranch :: Annex Bool
hasBranch = refExists fullname

{- Does origin/git-annex exist? -}
hasOrigin :: Annex Bool
hasOrigin = refExists originname

{- Does the git-annex branch or a foo/git-annex branch exist? -}
hasSomeBranch :: Annex Bool
hasSomeBranch = not . null <$> siblingBranches

{- List of all git-annex branches, including the main one and any
 - from remotes. -}
siblingBranches :: Annex [String]
siblingBranches = do
	g <- gitRepo
	r <- liftIO $ Git.pipeRead g [Param "show-ref", Param name]
	return $ map (last . words . L.unpack) (L.lines r)

{- Applies a function to modifiy the content of a file. -}
change :: FilePath -> (String -> String) -> Annex ()
change file a = lockJournal $ get file >>= return . a >>= set file

{- Records new content of a file into the journal. -}
set :: FilePath -> String -> Annex ()
set file content = do
	setJournalFile file content
	setCache file content

{- Gets the content of a file on the branch, or content from the journal, or
 - staged in the index.
 -
 - Returns an empty string if the file doesn't exist yet. -}
get :: FilePath -> Annex String
get file = do
	cached <- getCache file
	case cached of
		Just content -> return content
		Nothing -> do
			j <- getJournalFile file
			case j of
				Just content -> do
					setCache file content
					return content
				Nothing -> withIndexUpdate $ do
					content <- catFile fullname file
					setCache file content
					return content

{- Lists all files on the branch. There may be duplicates in the list. -}
files :: Annex [FilePath]
files = withIndexUpdate $ do
	g <- gitRepo
	bfiles <- liftIO $ Git.pipeNullSplit g
		[Params "ls-tree --name-only -r -z", Param fullname]
	jfiles <- getJournalledFiles
	return $ jfiles ++ bfiles

{- Records content for a file in the branch to the journal.
 -
 - Using the journal, rather than immediatly staging content to the index
 - avoids git needing to rewrite the index after every change. -}
setJournalFile :: FilePath -> String -> Annex ()
setJournalFile file content = do
	g <- gitRepo
	liftIO $ catch (write g) $ const $ do
		createDirectoryIfMissing True $ gitAnnexJournalDir g
		createDirectoryIfMissing True $ gitAnnexTmpDir g
		write g
	where
		-- journal file is written atomically
		write g = do
			let jfile = journalFile g file
			let tmpfile = gitAnnexTmpDir g </> takeFileName jfile
			writeBinaryFile tmpfile content
			renameFile tmpfile jfile

{- Gets any journalled content for a file in the branch. -}
getJournalFile :: FilePath -> Annex (Maybe String)
getJournalFile file = do
	g <- gitRepo
	liftIO $ catch (liftM Just . readFileStrict $ journalFile g file)
		(const $ return Nothing)

{- List of files that have updated content in the journal. -}
getJournalledFiles :: Annex [FilePath]
getJournalledFiles = map fileJournal <$> getJournalFiles

{- List of existing journal files. -}
getJournalFiles :: Annex [FilePath]
getJournalFiles = do
	g <- gitRepo
	fs <- liftIO $ catch (getDirectoryContents $ gitAnnexJournalDir g)
		(const $ return [])
	return $ filter (`notElem` [".", ".."]) fs

{- Stages the specified journalfiles. -}
stageJournalFiles :: [FilePath] -> Annex ()
stageJournalFiles fs = do
	g <- gitRepo
	withIndex $ liftIO $ do
		let dir = gitAnnexJournalDir g
		let paths = map (dir </>) fs
		-- inject all the journal files directly into git
		-- in one quick command
		(pid, fromh, toh) <- hPipeBoth "git" $ toCommand $
			Git.gitCommandLine g [Param "hash-object", Param "-w", Param "--stdin-paths"]
		_ <- forkProcess $ do
			hPutStr toh $ unlines paths
			hClose toh
			exitSuccess
		hClose toh
		s <- hGetContents fromh
		-- update the index, also in just one command
		Git.UnionMerge.update_index g $
			index_lines (lines s) $ map fileJournal fs
		hClose fromh
		forceSuccess pid
		mapM_ removeFile paths
	where
		index_lines shas = map genline . zip shas
		genline (sha, file) = Git.UnionMerge.update_index_line sha file

{- Produces a filename to use in the journal for a file on the branch.
 -
 - The journal typically won't have a lot of files in it, so the hashing
 - used in the branch is not necessary, and all the files are put directly
 - in the journal directory.
 -}
journalFile :: Git.Repo -> FilePath -> FilePath
journalFile repo file = gitAnnexJournalDir repo </> concatMap mangle file
	where
		mangle '/' = "_"
		mangle '_' = "__"
		mangle c = [c]

{- Converts a journal file (relative to the journal dir) back to the
 - filename on the branch. -}
fileJournal :: FilePath -> FilePath
fileJournal = replace "//" "_" . replace "_" "/"

{- Runs an action that modifies the journal, using locking to avoid
 - contention with other git-annex processes. -}
lockJournal :: Annex a -> Annex a
lockJournal a = do
	g <- gitRepo
	let file = gitAnnexJournalLock g
	bracketIO (lock file) unlock a
	where
		lock file = do
			l <- createFile file stdFileMode
			waitToSetLock l (WriteLock, AbsoluteSeek, 0, 0)
			return l
		unlock = closeFd