1{- Sqlite database used for exports to special remotes.
2 -
3 - Copyright 2017-2019 Joey Hess <id@joeyh.name>
4 -:
5 - Licensed under the GNU AGPL version 3 or higher.
6 -}
7
8{-# LANGUAGE CPP #-}
9{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell #-}
10{-# LANGUAGE OverloadedStrings, GADTs, FlexibleContexts #-}
11{-# LANGUAGE MultiParamTypeClasses, GeneralizedNewtypeDeriving #-}
12{-# LANGUAGE RankNTypes #-}
13{-# LANGUAGE DataKinds, FlexibleInstances #-}
14{-# LANGUAGE UndecidableInstances #-}
15#if MIN_VERSION_persistent_template(2,8,0)
16{-# LANGUAGE DerivingStrategies #-}
17{-# LANGUAGE StandaloneDeriving #-}
18#endif
19
20module Database.Export (
21	ExportHandle,
22	openDb,
23	closeDb,
24	writeLockDbWhile,
25	flushDbQueue,
26	addExportedLocation,
27	removeExportedLocation,
28	getExportedLocation,
29	isExportDirectoryEmpty,
30	getExportTreeCurrent,
31	recordExportTreeCurrent,
32	getExportTree,
33	getExportTreeKey,
34	addExportTree,
35	removeExportTree,
36	updateExportTree,
37	updateExportTree',
38	updateExportTreeFromLog,
39	updateExportDb,
40	ExportedId,
41	ExportedDirectoryId,
42	ExportTreeId,
43	ExportTreeCurrentId,
44	ExportUpdateResult(..),
45	ExportDiffUpdater,
46	runExportDiffUpdater,
47) where
48
49import Database.Types
50import qualified Database.Queue as H
51import Database.Init
52import Annex.Locations
53import Annex.Common hiding (delete)
54import Types.Export
55import Annex.Export
56import qualified Logs.Export as Log
57import Annex.LockFile
58import Annex.LockPool
59import Git.Types
60import Git.Sha
61import Git.FilePath
62import qualified Git.DiffTree
63import qualified Utility.RawFilePath as R
64
65import Database.Persist.Sql hiding (Key)
66import Database.Persist.TH
67import qualified System.FilePath.ByteString as P
68
69data ExportHandle = ExportHandle H.DbQueue UUID
70
71share [mkPersist sqlSettings, mkMigrate "migrateExport"] [persistLowerCase|
72-- Files that have been exported to the remote and are present on it.
73Exported
74  key Key
75  file SFilePath
76  ExportedIndex key file
77-- Directories that exist on the remote, and the files that are in them.
78ExportedDirectory
79  subdir SFilePath
80  file SFilePath
81  ExportedDirectoryIndex subdir file
82-- The content of the tree that has been exported to the remote.
83-- Not all of these files are necessarily present on the remote yet.
84ExportTree
85  key Key
86  file SFilePath
87  ExportTreeKeyFileIndex key file
88  ExportTreeFileKeyIndex file key
89-- The tree stored in ExportTree
90ExportTreeCurrent
91  tree SSha
92  UniqueTree tree
93|]
94
95{- Opens the database, creating it if it doesn't exist yet.
96 -
97 - Only a single process should write to the export at a time, so guard
98 - any writes with the gitAnnexExportLock.
99 -}
100openDb :: UUID -> Annex ExportHandle
101openDb u = do
102	dbdir <- fromRepo (gitAnnexExportDbDir u)
103	let db = dbdir P.</> "db"
104	unlessM (liftIO $ R.doesPathExist db) $ do
105		initDb db $ void $
106			runMigrationSilent migrateExport
107	h <- liftIO $ H.openDbQueue H.SingleWriter db "exported"
108	return $ ExportHandle h u
109
110closeDb :: ExportHandle -> Annex ()
111closeDb (ExportHandle h _) = liftIO $ H.closeDbQueue h
112
113queueDb :: ExportHandle -> SqlPersistM () -> IO ()
114queueDb (ExportHandle h _) = H.queueDb h checkcommit
115  where
116	-- commit queue after 1000 changes
117	checkcommit sz _lastcommittime
118		| sz > 1000 = return True
119		| otherwise = return False
120
121flushDbQueue :: ExportHandle -> IO ()
122flushDbQueue (ExportHandle h _) = H.flushDbQueue h
123
124recordExportTreeCurrent :: ExportHandle -> Sha -> IO ()
125recordExportTreeCurrent h s = queueDb h $ do
126	deleteWhere ([] :: [Filter ExportTreeCurrent])
127	void $ insertUnique $ ExportTreeCurrent $ toSSha s
128
129getExportTreeCurrent :: ExportHandle -> IO (Maybe Sha)
130getExportTreeCurrent (ExportHandle h _) = H.queryDbQueue h $ do
131	l <- selectList ([] :: [Filter ExportTreeCurrent]) []
132	case l of
133		(s:[]) -> return $ Just $ fromSSha $
134			exportTreeCurrentTree $ entityVal s
135		_ -> return Nothing
136
137addExportedLocation :: ExportHandle -> Key -> ExportLocation -> IO ()
138addExportedLocation h k el = queueDb h $ do
139	void $ insertUnique $ Exported k ef
140	let edirs = map
141		(\ed -> ExportedDirectory (SFilePath (fromExportDirectory ed)) ef)
142		(exportDirectories el)
143	putMany edirs
144  where
145	ef = SFilePath (fromExportLocation el)
146
147removeExportedLocation :: ExportHandle -> Key -> ExportLocation -> IO ()
148removeExportedLocation h k el = queueDb h $ do
149	deleteWhere [ExportedKey ==. k, ExportedFile ==. ef]
150	let subdirs = map (SFilePath . fromExportDirectory)
151		(exportDirectories el)
152	deleteWhere [ExportedDirectoryFile ==. ef, ExportedDirectorySubdir <-. subdirs]
153  where
154	ef = SFilePath (fromExportLocation el)
155
156{- Note that this does not see recently queued changes. -}
157getExportedLocation :: ExportHandle -> Key -> IO [ExportLocation]
158getExportedLocation (ExportHandle h _) k = H.queryDbQueue h $ do
159	l <- selectList [ExportedKey ==. k] []
160	return $ map (mkExportLocation . (\(SFilePath f) -> f) . exportedFile . entityVal) l
161
162{- Note that this does not see recently queued changes. -}
163isExportDirectoryEmpty :: ExportHandle -> ExportDirectory -> IO Bool
164isExportDirectoryEmpty (ExportHandle h _) d = H.queryDbQueue h $ do
165	l <- selectList [ExportedDirectorySubdir ==. ed] []
166	return $ null l
167  where
168	ed = SFilePath $ fromExportDirectory d
169
170{- Get locations in the export that might contain a key. -}
171getExportTree :: ExportHandle -> Key -> IO [ExportLocation]
172getExportTree (ExportHandle h _) k = H.queryDbQueue h $ do
173	l <- selectList [ExportTreeKey ==. k] []
174	return $ map (mkExportLocation . (\(SFilePath f) -> f) . exportTreeFile . entityVal) l
175
176{- Get keys that might be currently exported to a location.
177 -
178 - Note that this does not see recently queued changes.
179 -}
180getExportTreeKey :: ExportHandle -> ExportLocation -> IO [Key]
181getExportTreeKey (ExportHandle h _) el = H.queryDbQueue h $ do
182	map (exportTreeKey . entityVal)
183		<$> selectList [ExportTreeFile ==. ef] []
184  where
185	ef = SFilePath (fromExportLocation el)
186
187addExportTree :: ExportHandle -> Key -> ExportLocation -> IO ()
188addExportTree h k loc = queueDb h $
189	void $ insertUnique $ ExportTree k ef
190  where
191	ef = SFilePath (fromExportLocation loc)
192
193removeExportTree :: ExportHandle -> Key -> ExportLocation -> IO ()
194removeExportTree h k loc = queueDb h $
195	deleteWhere [ExportTreeKey ==. k, ExportTreeFile ==. ef]
196  where
197	ef = SFilePath (fromExportLocation loc)
198
199-- An action that is passed the old and new values that were exported,
200-- and updates state.
201type ExportDiffUpdater
202	= ExportHandle
203	-> Maybe Key
204	-- ^ old exported key
205	-> Maybe Key
206	-- ^ new exported key
207	-> Git.DiffTree.DiffTreeItem
208	-> Annex ()
209
210mkExportDiffUpdater
211	:: (ExportHandle -> Key -> ExportLocation -> IO ())
212	-> (ExportHandle -> Key -> ExportLocation -> IO ())
213	-> ExportDiffUpdater
214mkExportDiffUpdater removeold addnew h srcek dstek i = do
215	case srcek of
216		Nothing -> return ()
217		Just k -> liftIO $ removeold h k loc
218	case dstek of
219		Nothing -> return ()
220		Just k -> liftIO $ addnew h k loc
221  where
222	loc = mkExportLocation $ getTopFilePath $ Git.DiffTree.file i
223
224runExportDiffUpdater :: ExportDiffUpdater -> ExportHandle -> Sha -> Sha -> Annex ()
225runExportDiffUpdater updater h old new = do
226	(diff, cleanup) <- inRepo $
227		Git.DiffTree.diffTreeRecursive old new
228	forM_ diff $ \i -> do
229		srcek <- getek (Git.DiffTree.srcsha i)
230		dstek <- getek (Git.DiffTree.dstsha i)
231		updater h srcek dstek i
232	void $ liftIO cleanup
233  where
234	getek sha
235		| sha `elem` nullShas = return Nothing
236		| otherwise = Just <$> exportKey sha
237
238{- Diff from the old to the new tree and update the ExportTree table. -}
239updateExportTree :: ExportHandle -> Sha -> Sha -> Annex ()
240updateExportTree = runExportDiffUpdater updateExportTree'
241
242updateExportTree' :: ExportDiffUpdater
243updateExportTree' = mkExportDiffUpdater removeExportTree addExportTree
244
245{- Diff from the old to the new tree and update all tables in the export
246 - database. Should only be used when all the files in the new tree have
247 - been verified to already be present in the export remote. -}
248updateExportDb :: ExportHandle -> Sha -> Sha -> Annex ()
249updateExportDb = runExportDiffUpdater $ mkExportDiffUpdater removeold addnew
250  where
251	removeold h k loc = liftIO $ do
252		removeExportTree h k loc
253		removeExportedLocation h k loc
254	addnew h k loc = liftIO $ do
255		addExportTree h k loc
256		addExportedLocation h k loc
257
258{- Runs an action with the database locked for write. Waits for any other
259 - writers to finish first. The queue is flushed at the end.
260 -
261 - This first updates the ExportTree table with any new information
262 - from the git-annex branch export log.
263 -}
264writeLockDbWhile :: ExportHandle -> Annex a -> Annex a
265writeLockDbWhile db@(ExportHandle _ u) a = do
266	updatelck <- takeExclusiveLock (gitAnnexExportUpdateLock u)
267	withExclusiveLock (gitAnnexExportLock u) $ do
268		bracket_ (setup updatelck) cleanup a
269  where
270	setup updatelck = do
271		void $ updateExportTreeFromLog' db
272		-- flush the update so it's available immediately to
273		-- anything waiting on the updatelck
274		liftIO $ flushDbQueue db
275		liftIO $ dropLock updatelck
276	cleanup = liftIO $ flushDbQueue db
277
278data ExportUpdateResult = ExportUpdateSuccess | ExportUpdateConflict
279	deriving (Eq)
280
281{- Updates the ExportTree table with information from the
282 - git-annex branch export log.
283 -
284 - This can safely be called whether the database is locked for write or
285 - not. Either way, it will block until the update is complete.
286 -}
287updateExportTreeFromLog :: ExportHandle -> Annex ExportUpdateResult
288updateExportTreeFromLog db@(ExportHandle _ u) =
289	-- If another process or thread is performing the update,
290	-- this will block until it's done.
291	withExclusiveLock (gitAnnexExportUpdateLock u) $ do
292		-- If the database is locked by something else,
293		-- this will not run the update. But, in that case,
294		-- writeLockDbWhile is running, and has already
295		-- completed the update, so we don't need to do anything.
296		mr <- tryExclusiveLock (gitAnnexExportLock u) $
297			updateExportTreeFromLog' db
298		case mr of
299			Just r -> return r
300			Nothing -> do
301				old <- liftIO $ fromMaybe emptyTree
302					<$> getExportTreeCurrent db
303				l <- Log.getExport u
304				return $ case Log.exportedTreeishes l of
305					[] -> ExportUpdateSuccess
306					(new:[])
307						| new /= old -> ExportUpdateSuccess
308						| new == old -> ExportUpdateSuccess
309					_ts -> ExportUpdateConflict
310
311{- The database should be locked when calling this. -}
312updateExportTreeFromLog' :: ExportHandle -> Annex ExportUpdateResult
313updateExportTreeFromLog' db@(ExportHandle _ u) = do
314	old <- liftIO $ fromMaybe emptyTree
315		<$> getExportTreeCurrent db
316	l <- Log.getExport u
317	case Log.exportedTreeishes l of
318		[] -> return ExportUpdateSuccess
319		(new:[])
320			| new /= old -> do
321				updateExportTree db old new
322				liftIO $ recordExportTreeCurrent db new
323				liftIO $ flushDbQueue db
324				return ExportUpdateSuccess
325			| new == old -> return ExportUpdateSuccess
326		_ts -> return ExportUpdateConflict
327