summaryrefslogtreecommitdiff
path: root/Annex/Content.hs
blob: f328051e3a7bbffccc1837774041f0570234d75e (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
337
338
339
340
341
342
343
344
{- git-annex file content managing
 -
 - Copyright 2010 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Annex.Content (
	inAnnex,
	inAnnexSafe,
	lockContent,
	calcGitLink,
	logStatus,
	getViaTmp,
	getViaTmpUnchecked,
	withTmp,
	checkDiskSpace,
	moveAnnex,
	removeAnnex,
	fromAnnex,
	moveBad,
	getKeysPresent,
	saveState,
	downloadUrl,
	preseedTmp,
) where

import Control.Exception (bracket_)
import System.Posix.Types

import Common.Annex
import Logs.Location
import Annex.UUID
import qualified Git
import qualified Git.Config
import qualified Annex
import qualified Annex.Queue
import qualified Annex.Branch
import Utility.StatFS
import Utility.FileMode
import qualified Utility.Url as Url
import Types.Key
import Utility.DataUnits
import Utility.CopyFile
import Config
import Annex.Exception

{- Checks if a given key's content is currently present. -}
inAnnex :: Key -> Annex Bool
inAnnex = inAnnex' doesFileExist
inAnnex' :: (FilePath -> IO a) -> Key -> Annex a
inAnnex' a key = do
	whenM (fromRepo Git.repoIsUrl) $
		error "inAnnex cannot check remote repo"
	inRepo $ \g -> gitAnnexLocation key g >>= a

{- A safer check; the key's content must not only be present, but
 - is not in the process of being removed. -}
inAnnexSafe :: Key -> Annex (Maybe Bool)
inAnnexSafe = inAnnex' $ \f -> openForLock f False >>= check
	where
		check Nothing = return is_missing
		check (Just h) = do
			v <- getLock h (ReadLock, AbsoluteSeek, 0, 0)
			closeFd h
			return $ case v of
				Just _ -> is_locked
				Nothing -> is_unlocked
		is_locked = Nothing
		is_unlocked = Just True
		is_missing = Just False

{- Content is exclusively locked while running an action that might remove
 - it. (If the content is not present, no locking is done.) -}
lockContent :: Key -> Annex a -> Annex a
lockContent key a = do
	file <- inRepo $ gitAnnexLocation key
	bracketIO (openForLock file True >>= lock) unlock a
	where
		lock Nothing = return Nothing
		lock (Just l) = do
			v <- tryIO $ setLock l (WriteLock, AbsoluteSeek, 0, 0)
			case v of
				Left _ -> error "content is locked"
				Right _ -> return $ Just l
		unlock Nothing = return ()
		unlock (Just l) = closeFd l

openForLock :: FilePath -> Bool -> IO (Maybe Fd)
openForLock file writelock = bracket_ prep cleanup go
	where
		go = catchMaybeIO $ openFd file mode Nothing defaultFileFlags
		mode = if writelock then ReadWrite else ReadOnly
		{- Since files are stored with the write bit disabled,
		 - have to fiddle with permissions to open for an
		 - exclusive lock. -}
		forwritelock a = 
			when writelock $ whenM (doesFileExist file) a
		prep = forwritelock $ allowWrite file
		cleanup = forwritelock $ preventWrite file

{- Calculates the relative path to use to link a file to a key. -}
calcGitLink :: FilePath -> Key -> Annex FilePath
calcGitLink file key = do
	cwd <- liftIO getCurrentDirectory
	let absfile = fromMaybe whoops $ absNormPath cwd file
	loc <- inRepo $ gitAnnexLocation key
	return $ relPathDirToFile (parentDir absfile) loc
	where
		whoops = error $ "unable to normalize " ++ file

{- Updates the Logs.Location when a key's presence changes in the current
 - repository. -}
logStatus :: Key -> LogStatus -> Annex ()
logStatus key status = do
	u <- getUUID
	logChange key u status

{- Runs an action, passing it a temporary filename to get,
 - and if the action succeeds, moves the temp file into 
 - the annex as a key's content. -}
getViaTmp :: Key -> (FilePath -> Annex Bool) -> Annex Bool
getViaTmp key action = do
	tmp <- fromRepo $ gitAnnexTmpLocation key

	-- Check that there is enough free disk space.
	-- When the temp file already exists, count the space
	-- it is using as free.
	e <- liftIO $ doesFileExist tmp
	if e
		then do
			stat <- liftIO $ getFileStatus tmp
			checkDiskSpace' (fromIntegral $ fileSize stat) key
		else checkDiskSpace key

	when e $ liftIO $ allowWrite tmp

	getViaTmpUnchecked key action

prepTmp :: Key -> Annex FilePath
prepTmp key = do
	tmp <- fromRepo $ gitAnnexTmpLocation key
	liftIO $ createDirectoryIfMissing True (parentDir tmp)
	return tmp

{- Like getViaTmp, but does not check that there is enough disk space
 - for the incoming key. For use when the key content is already on disk
 - and not being copied into place. -}
getViaTmpUnchecked :: Key -> (FilePath -> Annex Bool) -> Annex Bool
getViaTmpUnchecked key action = do
	tmp <- prepTmp key
	success <- action tmp
	if success
		then do
			moveAnnex key tmp
			logStatus key InfoPresent
			return True
		else do
			-- the tmp file is left behind, in case caller wants
			-- to resume its transfer
			return False

{- Creates a temp file, runs an action on it, and cleans up the temp file. -}
withTmp :: Key -> (FilePath -> Annex a) -> Annex a
withTmp key action = do
	tmp <- prepTmp key
	res <- action tmp
	liftIO $ whenM (doesFileExist tmp) $ liftIO $ removeFile tmp
	return res

{- Checks that there is disk space available to store a given key,
 - throwing an error if not. -}
checkDiskSpace :: Key -> Annex ()
checkDiskSpace = checkDiskSpace' 0

checkDiskSpace' :: Integer -> Key -> Annex ()
checkDiskSpace' adjustment key = do
	g <- gitRepo
	r <- getConfig g "diskreserve" ""
	let reserve = fromMaybe megabyte $ readSize dataUnits r
	stats <- liftIO $ getFileSystemStats (gitAnnexDir g)
	sanitycheck r stats
	case (stats, keySize key) of
		(Nothing, _) -> return ()
		(_, Nothing) -> return ()
		(Just (FileSystemStats { fsStatBytesAvailable = have }), Just need) ->
			when (need + reserve > have + adjustment) $
				needmorespace (need + reserve - have - adjustment)
	where
		megabyte :: Integer
		megabyte = 1000000
		needmorespace n = unlessM (Annex.getState Annex.force) $
			error $ "not enough free space, need " ++ 
				roughSize storageUnits True n ++
				" more" ++ forcemsg
		forcemsg = " (use --force to override this check or adjust annex.diskreserve)"
		sanitycheck r stats
			| not (null r) && isNothing stats = do
				unlessM (Annex.getState Annex.force) $
					error $ "You have configured a diskreserve of "
						++ r ++
						" but disk space checking is not working"
						++ forcemsg
				return ()
			| otherwise = return ()

{- Moves a file into .git/annex/objects/
 -
 - What if the key there already has content? This could happen for
 - various reasons; perhaps the same content is being annexed again.
 - Perhaps there has been a hash collision generating the keys.
 -
 - The current strategy is to assume that in this case it's safe to delete
 - one of the two copies of the content; and the one already in the annex
 - is left there, assuming it's the original, canonical copy.
 -
 - I considered being more paranoid, and checking that both files had
 - the same content. Decided against it because A) users explicitly choose
 - a backend based on its hashing properties and so if they're dealing
 - with colliding files it's their own fault and B) adding such a check
 - would not catch all cases of colliding keys. For example, perhaps 
 - a remote has a key; if it's then added again with different content then
 - the overall system now has two different peices of content for that
 - key, and one of them will probably get deleted later. So, adding the
 - check here would only raise expectations that git-annex cannot truely
 - meet.
 -}
moveAnnex :: Key -> FilePath -> Annex ()
moveAnnex key src = do
	dest <- inRepo $ gitAnnexLocation key
	let dir = parentDir dest
	e <- liftIO $ doesFileExist dest
	if e
		then liftIO $ removeFile src
		else liftIO $ do
			createDirectoryIfMissing True dir
			allowWrite dir -- in case the directory already exists
			moveFile src dest
			preventWrite dest
			preventWrite dir

withObjectLoc :: Key -> ((FilePath, FilePath) -> Annex a) -> Annex a
withObjectLoc key a = do
	file <- inRepo $ gitAnnexLocation key
	let dir = parentDir file
	a (dir, file)

cleanObjectLoc :: Key -> Annex ()
cleanObjectLoc key = do
	file <- inRepo $ gitAnnexLocation key
	liftIO $ removeparents file (3 :: Int)
	where
		removeparents _ 0 = return ()
		removeparents file n = do
			let dir = parentDir file
			maybe (return ()) (const $ removeparents dir (n-1))
				=<< catchMaybeIO (removeDirectory dir)

{- Removes a key's file from .git/annex/objects/ -}
removeAnnex :: Key -> Annex ()
removeAnnex key = withObjectLoc key $ \(dir, file) -> do
	liftIO $ do
		allowWrite dir
		removeFile file
	cleanObjectLoc key

{- Moves a key's file out of .git/annex/objects/ -}
fromAnnex :: Key -> FilePath -> Annex ()
fromAnnex key dest = withObjectLoc key $ \(dir, file) -> do
	liftIO $ do
		allowWrite dir
		allowWrite file
		moveFile file dest
	cleanObjectLoc key

{- Moves a key out of .git/annex/objects/ into .git/annex/bad, and
 - returns the file it was moved to. -}
moveBad :: Key -> Annex FilePath
moveBad key = do
	src <- inRepo $ gitAnnexLocation key
	bad <- fromRepo gitAnnexBadDir
	let dest = bad </> takeFileName src
	liftIO $ do
		createDirectoryIfMissing True (parentDir dest)
		allowWrite (parentDir src)
		moveFile src dest
	cleanObjectLoc key
	logStatus key InfoMissing
	return dest

{- List of keys whose content exists in .git/annex/objects/ -}
getKeysPresent :: Annex [Key]
getKeysPresent = getKeysPresent' =<< fromRepo gitAnnexObjectDir
getKeysPresent' :: FilePath -> Annex [Key]
getKeysPresent' dir = do
	exists <- liftIO $ doesDirectoryExist dir
	if not exists
		then return []
		else liftIO $ do
			-- 2 levels of hashing
			levela <- dirContents dir
			levelb <- mapM dirContents levela
			contents <- mapM dirContents (concat levelb)
			let files = concat contents
			return $ mapMaybe (fileKey . takeFileName) files

{- Things to do to record changes to content when shutting down.
 -
 - It's acceptable to avoid committing changes to the branch,
 - especially if performing a short-lived action.
 -}
saveState :: Bool -> Annex ()
saveState oneshot = do
	Annex.Queue.flush False
	unless oneshot $ do
		alwayscommit <- Git.configTrue <$> fromRepo (Git.Config.get "annex.alwayscommit" "true")
		if alwayscommit
			then Annex.Branch.commit "update"
			else Annex.Branch.stage

{- Downloads content from any of a list of urls. -}
downloadUrl :: [Url.URLString] -> FilePath -> Annex Bool
downloadUrl urls file = do
	g <- gitRepo
	o <- map Param . words <$> getConfig g "web-options" ""
	liftIO $ anyM (\u -> Url.download u o file) urls

{- Copies a key's content, when present, to a temp file.
 - This is used to speed up some rsyncs. -}
preseedTmp :: Key -> FilePath -> Annex Bool
preseedTmp key file = go =<< inAnnex key
	where
		go False = return False
		go True = do
			ok <- copy
			when ok $ liftIO $ allowWrite file
			return ok
		copy = do
			present <- liftIO $ doesFileExist file
			if present
				then return True
				else do
					s <- inRepo $ gitAnnexLocation key
					liftIO $ copyFileExternal s file