summaryrefslogtreecommitdiff
path: root/Command/Export.hs
blob: dfa4529569b338d1526bb43e64c1c9676eef5a61 (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
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
{- git-annex command
 -
 - Copyright 2017 Joey Hess <id@joeyh.name>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

{-# LANGUAGE TupleSections, BangPatterns #-}

module Command.Export where

import Command
import qualified Annex
import qualified Git
import qualified Git.DiffTree
import qualified Git.LsTree
import qualified Git.Ref
import Git.Types
import Git.FilePath
import Git.Sha
import Types.Remote
import Types.Export
import Annex.Export
import Annex.Content
import Annex.Transfer
import Annex.CatFile
import Annex.LockFile
import Logs.Location
import Logs.Export
import Database.Export
import Messages.Progress
import Config
import Utility.Tmp
import Utility.Metered

import qualified Data.ByteString.Lazy as L
import qualified Data.Map as M
import Control.Concurrent

cmd :: Command
cmd = command "export" SectionCommon
	"export content to a remote"
	paramTreeish (seek <$$> optParser)

data ExportOptions = ExportOptions
	{ exportTreeish :: Git.Ref
	, exportRemote :: DeferredParse Remote
	, exportTracking :: Bool
	}

optParser :: CmdParamsDesc -> Parser ExportOptions
optParser _ = ExportOptions
	<$> (Git.Ref <$> parsetreeish)
	<*> (parseRemoteOption <$> parseToOption)
	<*> parsetracking
  where
	parsetreeish = argument str
		( metavar paramTreeish
		)
	parsetracking = switch
		( long "tracking"
		<> help ("track changes to the " ++ paramTreeish)
		)

-- To handle renames which swap files, the exported file is first renamed
-- to a stable temporary name based on the key.
exportTempName :: ExportKey -> ExportLocation
exportTempName ek = mkExportLocation $ 
	".git-annex-tmp-content-" ++ key2file (asKey (ek))

seek :: ExportOptions -> CommandSeek
seek o = do
	r <- getParsed (exportRemote o)
	unlessM (isExportSupported r) $
		giveup "That remote does not support exports."
	when (exportTracking o) $
		setConfig (remoteConfig r "export-tracking")
			(fromRef $ exportTreeish o)
	new <- fromMaybe (giveup "unknown tree") <$>
		-- Dereference the tree pointed to by the branch, commit,
		-- or tag.
		inRepo (Git.Ref.tree (exportTreeish o))
	withExclusiveLock (gitAnnexExportLock (uuid r)) $ do
		db <- openDb (uuid r)
		ea <- exportActions r
		changeExport r ea db new
		unlessM (Annex.getState Annex.fast) $
			void $ fillExport r ea db new
		closeDb db

-- | Changes what's exported to the remote. Does not upload any new
-- files, but does delete and rename files already exported to the remote.
changeExport :: Remote -> ExportActions Annex -> ExportHandle -> Git.Ref -> CommandSeek
changeExport r ea db new = do
	old <- getExport (uuid r)
	recordExportBeginning (uuid r) new
	
	-- Clean up after incomplete export of a tree, in which
	-- the next block of code below may have renamed some files to
	-- temp files. Diff from the incomplete tree to the new tree,
	-- and delete any temp files that the new tree can't use.
	forM_ (concatMap incompleteExportedTreeish old) $ \incomplete ->
		mapdiff (\diff -> startRecoverIncomplete r ea db (Git.DiffTree.srcsha diff) (Git.DiffTree.file diff))
			incomplete
			new

	-- Diff the old and new trees, and delete or rename to new name all
	-- changed files in the export. After this, every file that remains
	-- in the export will have the content from the new treeish.
	-- 
	-- When there was an export conflict, this resolves it.
	--
	-- The ExportTree is also updated here to reflect the new tree.
	case map exportedTreeish old of
		[] -> updateExportTree db emptyTree new
		[oldtreesha] -> do
			diffmap <- mkDiffMap oldtreesha new db
			let seekdiffmap a = seekActions $ pure $ map a (M.toList diffmap)
			-- Rename old files to temp, or delete.
			seekdiffmap $ \(ek, (moldf, mnewf)) -> do
				case (moldf, mnewf) of
					(Just oldf, Just _newf) ->
						startMoveToTempName r ea db oldf ek
					(Just oldf, Nothing) -> 
						startUnexport' r ea db oldf ek
					_ -> stop
			-- Rename from temp to new files.
			seekdiffmap $ \(ek, (moldf, mnewf)) ->
				case (moldf, mnewf) of
					(Just _oldf, Just newf) ->
						startMoveFromTempName r ea db ek newf
					_ -> stop
		ts -> do
			warning "Export conflict detected. Different trees have been exported to the same special remote. Resolving.."
			forM_ ts $ \oldtreesha -> do
				-- Unexport both the srcsha and the dstsha,
				-- because the wrong content may have
				-- been renamed to the dstsha due to the
				-- export conflict.
				let unexportboth d = 
					[ Git.DiffTree.srcsha d 
					, Git.DiffTree.dstsha d
					]
				-- Don't rename to temp, because the
				-- content is unknown; delete instead.
				mapdiff
					(\diff -> startUnexport r ea db (Git.DiffTree.file diff) (unexportboth diff))
					oldtreesha new
			updateExportTree db emptyTree new
	liftIO $ recordExportTreeCurrent db new

	-- Waiting until now to record the export guarantees that,
	-- if this export is interrupted, there are no files left over
	-- from a previous export, that are not part of this export.
	c <- Annex.getState Annex.errcounter
	when (c == 0) $ do
		recordExport (uuid r) $ ExportChange
			{ oldTreeish = map exportedTreeish old
			, newTreeish = new
			}
  where
	mapdiff a oldtreesha newtreesha = do
		(diff, cleanup) <- inRepo $
			Git.DiffTree.diffTreeRecursive oldtreesha newtreesha
		seekActions $ pure $ map a diff
		void $ liftIO cleanup

-- Map of old and new filenames for each changed ExportKey in a diff.
type DiffMap = M.Map ExportKey (Maybe TopFilePath, Maybe TopFilePath)

mkDiffMap :: Git.Ref -> Git.Ref -> ExportHandle -> Annex DiffMap
mkDiffMap old new db = do
	(diff, cleanup) <- inRepo $ Git.DiffTree.diffTreeRecursive old new
	diffmap <- M.fromListWith combinedm . concat <$> forM diff mkdm
	void $ liftIO cleanup
	return diffmap
  where
	combinedm (srca, dsta) (srcb, dstb) = (srca <|> srcb, dsta <|> dstb)
	mkdm i = do
		srcek <- getek (Git.DiffTree.srcsha i)
		dstek <- getek (Git.DiffTree.dstsha i)
		updateExportTree' db srcek dstek i
		return $ catMaybes
			[ (, (Just (Git.DiffTree.file i), Nothing)) <$> srcek
			, (, (Nothing, Just (Git.DiffTree.file i))) <$> dstek
			]
	getek sha
		| sha == nullSha = return Nothing
		| otherwise = Just <$> exportKey sha

-- | Upload all exported files that are not yet in the remote,
-- Returns True when files were uploaded.
fillExport :: Remote -> ExportActions Annex -> ExportHandle -> Git.Ref -> Annex Bool
fillExport r ea db new = do
	(l, cleanup) <- inRepo $ Git.LsTree.lsTree new
	cvar <- liftIO $ newMVar False
	seekActions $ pure $ map (startExport r ea db cvar) l
	void $ liftIO $ cleanup
	liftIO $ takeMVar cvar

startExport :: Remote -> ExportActions Annex -> ExportHandle -> MVar Bool -> Git.LsTree.TreeItem -> CommandStart
startExport r ea db cvar ti = do
	ek <- exportKey (Git.LsTree.sha ti)
	stopUnless (liftIO $ notElem loc <$> getExportedLocation db (asKey ek)) $ do
		showStart ("export " ++ name r) f
		liftIO $ modifyMVar_ cvar (pure . const True)
		next $ performExport r ea db ek af (Git.LsTree.sha ti) loc
  where
	loc = mkExportLocation f
	f = getTopFilePath (Git.LsTree.file ti)
	af = AssociatedFile (Just f)

performExport :: Remote -> ExportActions Annex -> ExportHandle -> ExportKey -> AssociatedFile -> Sha -> ExportLocation -> CommandPerform
performExport r ea db ek af contentsha loc = do
	let storer = storeExport ea
	sent <- case ek of
		AnnexKey k -> ifM (inAnnex k)
			( metered Nothing k $ \m -> do
				let rollback = void $
					performUnexport r ea db [ek] loc
				notifyTransfer Upload af $
					upload (uuid r) k af noRetry $ \pm -> do
						let m' = combineMeterUpdate pm m
						sendAnnex k rollback
							(\f -> storer f k loc m')
			, do
				showNote "not available"
				return False
			)
		-- Sending a non-annexed file.
		GitKey sha1k -> metered Nothing sha1k $ \m ->
			withTmpFile "export" $ \tmp h -> do
				b <- catObject contentsha
				liftIO $ L.hPut h b
				liftIO $ hClose h
				storer tmp sha1k loc m
	if sent
		then next $ cleanupExport r db ek loc
		else stop

cleanupExport :: Remote -> ExportHandle -> ExportKey -> ExportLocation -> CommandCleanup
cleanupExport r db ek loc = do
	liftIO $ addExportedLocation db (asKey ek) loc
	logChange (asKey ek) (uuid r) InfoPresent
	return True

startUnexport :: Remote -> ExportActions Annex -> ExportHandle -> TopFilePath -> [Git.Sha] -> CommandStart
startUnexport r ea db f shas = do
	eks <- forM (filter (/= nullSha) shas) exportKey
	if null eks
		then stop
		else do
			showStart ("unexport " ++ name r) f'
			next $ performUnexport r ea db eks loc
  where
	loc = mkExportLocation f'
	f' = getTopFilePath f

startUnexport' :: Remote -> ExportActions Annex -> ExportHandle -> TopFilePath -> ExportKey -> CommandStart
startUnexport' r ea db f ek = do
	showStart ("unexport " ++ name r) f'
	next $ performUnexport r ea db [ek] loc
  where
	loc = mkExportLocation f'
	f' = getTopFilePath f

performUnexport :: Remote -> ExportActions Annex -> ExportHandle -> [ExportKey] -> ExportLocation -> CommandPerform
performUnexport r ea db eks loc = do
	ifM (allM (\ek -> removeExport ea (asKey ek) loc) eks)
		( next $ cleanupUnexport r ea db eks loc
		, stop
		)

cleanupUnexport :: Remote -> ExportActions Annex -> ExportHandle -> [ExportKey] -> ExportLocation -> CommandCleanup
cleanupUnexport r ea db eks loc = do
	liftIO $ do
		forM_ eks $ \ek ->
			removeExportedLocation db (asKey ek) loc
		flushDbQueue db

	remaininglocs <- liftIO $ 
		concat <$> forM eks (\ek -> getExportedLocation db (asKey ek))
	when (null remaininglocs) $
		forM_ eks $ \ek ->
			logChange (asKey ek) (uuid r) InfoMissing
	
	removeEmptyDirectories ea db loc (map asKey eks)

startRecoverIncomplete :: Remote -> ExportActions Annex -> ExportHandle -> Git.Sha -> TopFilePath -> CommandStart
startRecoverIncomplete r ea db sha oldf
	| sha == nullSha = stop
	| otherwise = do
		ek <- exportKey sha
		let loc = exportTempName ek
		showStart ("unexport " ++ name r) (fromExportLocation loc)
		liftIO $ removeExportedLocation db (asKey ek) oldloc
		next $ performUnexport r ea db [ek] loc
  where
	oldloc = mkExportLocation oldf'
	oldf' = getTopFilePath oldf

startMoveToTempName :: Remote -> ExportActions Annex -> ExportHandle -> TopFilePath -> ExportKey -> CommandStart
startMoveToTempName r ea db f ek = do
	showStart ("rename " ++ name r) (f' ++ " -> " ++ fromExportLocation tmploc)
	next $ performRename r ea db ek loc tmploc
  where
	loc = mkExportLocation f'
	f' = getTopFilePath f
	tmploc = exportTempName ek

startMoveFromTempName :: Remote -> ExportActions Annex -> ExportHandle -> ExportKey -> TopFilePath -> CommandStart
startMoveFromTempName r ea db ek f = do
	let tmploc = exportTempName ek
	stopUnless (liftIO $ elem tmploc <$> getExportedLocation db (asKey ek)) $ do
		showStart ("rename " ++ name r) (fromExportLocation tmploc ++ " -> " ++ f')
		next $ performRename r ea db ek tmploc loc
  where
	loc = mkExportLocation f'
	f' = getTopFilePath f

performRename :: Remote -> ExportActions Annex -> ExportHandle -> ExportKey -> ExportLocation -> ExportLocation -> CommandPerform
performRename r ea db ek src dest = do
	ifM (renameExport ea (asKey ek) src dest)
		( next $ cleanupRename ea db ek src dest
		-- In case the special remote does not support renaming,
		-- unexport the src instead.
		, do
			warning "rename failed; deleting instead"
			performUnexport r ea db [ek] src
		)

cleanupRename :: ExportActions Annex -> ExportHandle -> ExportKey -> ExportLocation -> ExportLocation -> CommandCleanup
cleanupRename ea db ek src dest = do
	liftIO $ do
		removeExportedLocation db (asKey ek) src
		addExportedLocation db (asKey ek) dest
		flushDbQueue db
	if exportDirectories src /= exportDirectories dest
		then removeEmptyDirectories ea db src [asKey ek]
		else return True

-- | Remove empty directories from the export. Call after removing an
-- exported file, and after calling removeExportLocation and flushing the
-- database.
removeEmptyDirectories :: ExportActions Annex -> ExportHandle -> ExportLocation -> [Key] -> Annex Bool
removeEmptyDirectories ea db loc ks
	| null (exportDirectories loc) = return True
	| otherwise = case removeExportDirectory ea of
		Nothing -> return True
		Just removeexportdirectory -> do
			ok <- allM (go removeexportdirectory) 
				(reverse (exportDirectories loc))
			unless ok $ liftIO $ do
				-- Add location back to export database, 
				-- so this is tried again next time.
				forM_ ks $ \k ->
					addExportedLocation db k loc
				flushDbQueue db
			return ok
  where
	go removeexportdirectory d = 
		ifM (liftIO $ isExportDirectoryEmpty db d)
			( removeexportdirectory d
			, return True
			)