From 36533ce176ec653f62fe740f9907f527e4f36361 Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Mon, 18 Sep 2017 18:40:16 -0400
Subject: merge changes made on other repos into ExportTree

Now when one repository has exported a tree, another repository can get
files from the export, after syncing.

There's a bug: While the database update works, somehow the database on
disk does not get updated, and so the database update is run the next
time, etc. Wasn't able to figure out why yet.

This commit was sponsored by Ole-Morten Duesund on Patreon.
---
 Remote/Helper/Export.hs | 61 ++++++++++++++++++++++++++-----------------------
 1 file changed, 33 insertions(+), 28 deletions(-)

(limited to 'Remote/Helper')

diff --git a/Remote/Helper/Export.hs b/Remote/Helper/Export.hs
index 9b31baca3..d62c5a7e8 100644
--- a/Remote/Helper/Export.hs
+++ b/Remote/Helper/Export.hs
@@ -12,13 +12,16 @@ module Remote.Helper.Export where
 import Annex.Common
 import Types.Remote
 import Types.Backend
-import Types.Export
 import Types.Key
 import Backend
 import Remote.Helper.Encryptable (isEncrypted)
 import Database.Export
+import Logs.Export
+import Annex.LockFile
+import Git.Sha
 
 import qualified Data.Map as M
+import Control.Concurrent.STM
 
 -- | Use for remotes that do not support exports.
 class HasExportUnsupported a where
@@ -89,6 +92,33 @@ adjustExportable r = case M.lookup "exporttree" (config r) of
 		}
 	isexport = do
 		db <- openDb (uuid r)
+
+		updateflag <- liftIO newEmptyTMVarIO
+		let updateonce = liftIO $ atomically $
+			ifM (isEmptyTMVar updateflag)
+				( do
+					putTMVar updateflag ()
+					return True
+				, return False
+				)
+		
+		-- Get export locations for a key. Checks once
+		-- if the export log is different than the database and
+		-- updates the database, to notice when an export has been
+		-- updated from another repository.
+		let getexportlocs = \k -> do
+			whenM updateonce $ withExclusiveLock (gitAnnexExportLock (uuid r)) $ do
+				old <- liftIO $ fromMaybe emptyTree
+					<$> getExportTreeCurrent db
+				l <- getExport (uuid r)
+				case map exportedTreeish l of
+					(new:[]) | new /= old -> do
+						updateExportTree db old new
+						liftIO $ recordExportTreeCurrent db new
+						liftIO $ flushDbQueue db
+					_ -> return ()
+			liftIO $ getExportTree db k
+
 		return $ r
 			-- Storing a key on an export could be implemented,
 			-- but it would perform unncessary work
@@ -104,7 +134,7 @@ adjustExportable r = case M.lookup "exporttree" (config r) of
 			, retrieveKeyFile = \k _af dest p -> unVerified $
 				if maybe False (isJust . verifyKeyContent) (maybeLookupBackendVariety (keyVariety k))
 					then do
-						locs <- liftIO $ getExportTree db k
+						locs <- getexportlocs k
 						case locs of
 							[] -> do
 								warning "unknown export location"
@@ -135,34 +165,9 @@ adjustExportable r = case M.lookup "exporttree" (config r) of
 			, checkPresent = \k -> do
 				ea <- exportActions r
 				anyM (checkPresentExport ea k)
-					=<< liftIO (getExportTree db k)
+					=<< getexportlocs k
 			, mkUnavailable = return Nothing
 			, getInfo = do
 				is <- getInfo r
 				return (is++[("export", "yes")])
 			}
-
--- | 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
-			)
-- 
cgit v1.2.3