summaryrefslogtreecommitdiff
path: root/Database/Export.hs
blob: 0da0173fad7d2700e26334dad53fb628f762840a (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
{- Sqlite database used for exports to special remotes.
 -
 - Copyright 2017-2019 Joey Hess <id@joeyh.name>
 -:
 - Licensed under the GNU AGPL version 3 or higher.
 -}

{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell #-}
{-# LANGUAGE OverloadedStrings, GADTs, FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses, GeneralizedNewtypeDeriving #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE UndecidableInstances #-}

module Database.Export (
	ExportHandle,
	openDb,
	closeDb,
	writeLockDbWhile,
	flushDbQueue,
	addExportedLocation,
	removeExportedLocation,
	getExportedLocation,
	isExportDirectoryEmpty,
	getExportTreeCurrent,
	recordExportTreeCurrent,
	getExportTree,
	getExportTreeKey,
	addExportTree,
	removeExportTree,
	updateExportTree,
	updateExportTree',
	updateExportTreeFromLog,
	updateExportDb,
	ExportedId,
	ExportedDirectoryId,
	ExportTreeId,
	ExportTreeCurrentId,
	ExportUpdateResult(..),
	ExportDiffUpdater,
	runExportDiffUpdater,
) where

import Database.Types
import qualified Database.Queue as H
import Database.Init
import Annex.Locations
import Annex.Common hiding (delete)
import Types.Export
import Annex.Export
import qualified Logs.Export as Log
import Annex.LockFile
import Annex.LockPool
import Git.Types
import Git.Sha
import Git.FilePath
import qualified Git.DiffTree

import Database.Persist.Sql hiding (Key)
import Database.Persist.TH

data ExportHandle = ExportHandle H.DbQueue UUID

share [mkPersist sqlSettings, mkMigrate "migrateExport"] [persistLowerCase|
-- Files that have been exported to the remote and are present on it.
Exported
  key IKey
  file SFilePath
  ExportedIndex key file
-- Directories that exist on the remote, and the files that are in them.
ExportedDirectory
  subdir SFilePath
  file SFilePath
  ExportedDirectoryIndex subdir file
-- The content of the tree that has been exported to the remote.
-- Not all of these files are necessarily present on the remote yet.
ExportTree
  key IKey
  file SFilePath
  ExportTreeIndex key file
-- The tree stored in ExportTree
ExportTreeCurrent
  tree SRef
  UniqueTree tree
|]

{- Opens the database, creating it if it doesn't exist yet.
 -
 - Only a single process should write to the export at a time, so guard
 - any writes with the gitAnnexExportLock.
 -}
openDb :: UUID -> Annex ExportHandle
openDb u = do
	dbdir <- fromRepo (gitAnnexExportDbDir u)
	let db = dbdir </> "db"
	unlessM (liftIO $ doesFileExist db) $ do
		initDb db $ void $
			runMigrationSilent migrateExport
	h <- liftIO $ H.openDbQueue H.SingleWriter db "exported"
	return $ ExportHandle h u

closeDb :: ExportHandle -> Annex ()
closeDb (ExportHandle h _) = liftIO $ H.closeDbQueue h

queueDb :: ExportHandle -> SqlPersistM () -> IO ()
queueDb (ExportHandle h _) = H.queueDb h checkcommit
  where
	-- commit queue after 1000 changes
	checkcommit sz _lastcommittime
		| sz > 1000 = return True
		| otherwise = return False

flushDbQueue :: ExportHandle -> IO ()
flushDbQueue (ExportHandle h _) = H.flushDbQueue h

recordExportTreeCurrent :: ExportHandle -> Sha -> IO ()
recordExportTreeCurrent h s = queueDb h $ do
	deleteWhere ([] :: [Filter ExportTreeCurrent])
	void $ insertUnique $ ExportTreeCurrent $ toSRef s

getExportTreeCurrent :: ExportHandle -> IO (Maybe Sha)
getExportTreeCurrent (ExportHandle h _) = H.queryDbQueue h $ do
	l <- selectList ([] :: [Filter ExportTreeCurrent]) []
	case l of
		(s:[]) -> return $ Just $ fromSRef $ exportTreeCurrentTree $ entityVal s
		_ -> return Nothing

addExportedLocation :: ExportHandle -> Key -> ExportLocation -> IO ()
addExportedLocation h k el = queueDb h $ do
	void $ insertUnique $ Exported ik ef
	let edirs = map
		(\ed -> ExportedDirectory (toSFilePath (fromExportDirectory ed)) ef)
		(exportDirectories el)
	putMany edirs
  where
	ik = toIKey k
	ef = toSFilePath (fromExportLocation el)

removeExportedLocation :: ExportHandle -> Key -> ExportLocation -> IO ()
removeExportedLocation h k el = queueDb h $ do
	deleteWhere [ExportedKey ==. ik, ExportedFile ==. ef]
	let subdirs = map (toSFilePath . fromExportDirectory)
		(exportDirectories el)
	deleteWhere [ExportedDirectoryFile ==. ef, ExportedDirectorySubdir <-. subdirs]
  where
	ik = toIKey k
	ef = toSFilePath (fromExportLocation el)

{- Note that this does not see recently queued changes. -}
getExportedLocation :: ExportHandle -> Key -> IO [ExportLocation]
getExportedLocation (ExportHandle h _) k = H.queryDbQueue h $ do
	l <- selectList [ExportedKey ==. ik] []
	return $ map (mkExportLocation . fromSFilePath . exportedFile . entityVal) l
  where
	ik = toIKey k

{- Note that this does not see recently queued changes. -}
isExportDirectoryEmpty :: ExportHandle -> ExportDirectory -> IO Bool
isExportDirectoryEmpty (ExportHandle h _) d = H.queryDbQueue h $ do
	l <- selectList [ExportedDirectorySubdir ==. ed] []
	return $ null l
  where
	ed = toSFilePath $ fromExportDirectory d

{- Get locations in the export that might contain a key. -}
getExportTree :: ExportHandle -> Key -> IO [ExportLocation]
getExportTree (ExportHandle h _) k = H.queryDbQueue h $ do
	l <- selectList [ExportTreeKey ==. ik] []
	return $ map (mkExportLocation . fromSFilePath . exportTreeFile . entityVal) l
  where
	ik = toIKey k

{- Get keys that might be currently exported to a location.
 -
 - Note that the database does not currently have an index to make this
 - fast.
 -
 - Note that this does not see recently queued changes.
 -}
getExportTreeKey :: ExportHandle -> ExportLocation -> IO [Key]
getExportTreeKey (ExportHandle h _) el = H.queryDbQueue h $ do
	map (fromIKey . exportTreeKey . entityVal) 
		<$> selectList [ExportTreeFile ==. ef] []
  where
	ef = toSFilePath (fromExportLocation el)

addExportTree :: ExportHandle -> Key -> ExportLocation -> IO ()
addExportTree h k loc = queueDb h $
	void $ insertUnique $ ExportTree ik ef
  where
	ik = toIKey k
	ef = toSFilePath (fromExportLocation loc)

removeExportTree :: ExportHandle -> Key -> ExportLocation -> IO ()
removeExportTree h k loc = queueDb h $
	deleteWhere [ExportTreeKey ==. ik, ExportTreeFile ==. ef]
  where
	ik = toIKey k
	ef = toSFilePath (fromExportLocation loc)

-- An action that is passed the old and new values that were exported,
-- and updates state.
type ExportDiffUpdater
	= ExportHandle
	-> Maybe ExportKey
	-- ^ old exported key
	-> Maybe ExportKey
	-- ^ new exported key
	-> Git.DiffTree.DiffTreeItem
	-> Annex ()

mkExportDiffUpdater
	:: (ExportHandle -> Key -> ExportLocation -> IO ())
	-> (ExportHandle -> Key -> ExportLocation -> IO ())
	-> ExportDiffUpdater
mkExportDiffUpdater removeold addnew h srcek dstek i = do
	case srcek of
		Nothing -> return ()
		Just k -> liftIO $ removeold h (asKey k) loc
	case dstek of
		Nothing -> return ()
		Just k -> liftIO $ addnew h (asKey k) loc
  where
	loc = mkExportLocation $ getTopFilePath $ Git.DiffTree.file i

runExportDiffUpdater :: ExportDiffUpdater -> ExportHandle -> Sha -> Sha -> Annex ()
runExportDiffUpdater updater h old new = do
	(diff, cleanup) <- inRepo $
		Git.DiffTree.diffTreeRecursive old new
	forM_ diff $ \i -> do
		srcek <- getek (Git.DiffTree.srcsha i)
		dstek <- getek (Git.DiffTree.dstsha i)
		updater h srcek dstek i
	void $ liftIO cleanup
  where
	getek sha
		| sha == nullSha = return Nothing
		| otherwise = Just <$> exportKey sha

{- Diff from the old to the new tree and update the ExportTree table. -}
updateExportTree :: ExportHandle -> Sha -> Sha -> Annex ()
updateExportTree = runExportDiffUpdater updateExportTree'

updateExportTree' :: ExportDiffUpdater
updateExportTree' = mkExportDiffUpdater removeExportTree addExportTree

{- Diff from the old to the new tree and update all tables in the export
 - database. Should only be used when all the files in the new tree have
 - been verified to already be present in the export remote. -}
updateExportDb :: ExportHandle -> Sha -> Sha -> Annex ()
updateExportDb = runExportDiffUpdater $ mkExportDiffUpdater removeold addnew
  where
	removeold h k loc = liftIO $ do
		removeExportTree h k loc
		removeExportedLocation h k loc
	addnew h k loc = liftIO $ do
		addExportTree h k loc
		addExportedLocation h k loc

{- Runs an action with the database locked for write. Waits for any other
 - writers to finish first. The queue is flushed at the end.
 -
 - This first updates the ExportTree table with any new information 
 - from the git-annex branch export log.
 -}
writeLockDbWhile :: ExportHandle -> Annex a -> Annex a
writeLockDbWhile db@(ExportHandle _ u) a = do
	updatelck <- takeExclusiveLock (gitAnnexExportUpdateLock u)
	withExclusiveLock (gitAnnexExportLock u) $ do
		bracket_ (setup updatelck) cleanup a
  where
	setup updatelck = do
		void $ updateExportTreeFromLog' db
		-- flush the update so it's available immediately to
		-- anything waiting on the updatelck
		liftIO $ flushDbQueue db
		liftIO $ dropLock updatelck
	cleanup = liftIO $ flushDbQueue db

data ExportUpdateResult = ExportUpdateSuccess | ExportUpdateConflict
	deriving (Eq)

{- Updates the ExportTree table with information from the
 - git-annex branch export log.
 -
 - This can safely be called whether the database is locked for write or
 - not. Either way, it will block until the update is complete.
 -}
updateExportTreeFromLog :: ExportHandle -> Annex ExportUpdateResult
updateExportTreeFromLog db@(ExportHandle _ u) =
	-- If another process or thread is performing the update,
	-- this will block until it's done.
	withExclusiveLock (gitAnnexExportUpdateLock u) $ do
		-- If the database is locked by something else,
		-- this will not run the update. But, in that case,
		-- writeLockDbWhile is running, and has already
		-- completed the update, so we don't need to do anything.
		mr <- tryExclusiveLock (gitAnnexExportLock u) $
			updateExportTreeFromLog' db
		case mr of
			Just r -> return r
			Nothing -> do
				old <- liftIO $ fromMaybe emptyTree
					<$> getExportTreeCurrent db
				l <- Log.getExport u
				return $ case Log.exportedTreeishes l of
					[] -> ExportUpdateSuccess
					(new:[]) 
						| new /= old -> ExportUpdateSuccess
						| new == old -> ExportUpdateSuccess
					_ts -> ExportUpdateConflict

{- The database should be locked when calling this. -}
updateExportTreeFromLog' :: ExportHandle -> Annex ExportUpdateResult
updateExportTreeFromLog' db@(ExportHandle _ u) = do
	old <- liftIO $ fromMaybe emptyTree
		<$> getExportTreeCurrent db
	l <- Log.getExport u
	case Log.exportedTreeishes l of
		[] -> return ExportUpdateSuccess
		(new:[]) 
			| new /= old -> do
				updateExportTree db old new
				liftIO $ recordExportTreeCurrent db new
				liftIO $ flushDbQueue db
				return ExportUpdateSuccess
			| new == old -> return ExportUpdateSuccess
		_ts -> return ExportUpdateConflict