diff options
author | Joey Hess <joeyh@joeyh.name> | 2017-09-18 18:40:16 -0400 |
---|---|---|
committer | Joey Hess <joeyh@joeyh.name> | 2017-09-18 19:21:41 -0400 |
commit | 36533ce176ec653f62fe740f9907f527e4f36361 (patch) | |
tree | 0c507668c7d19950efa7877ca2155e71ccdb1472 /Remote/Helper | |
parent | 7576fff0131d4f86dc495d58f62490c3264e0e54 (diff) |
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.
Diffstat (limited to 'Remote/Helper')
-rw-r--r-- | Remote/Helper/Export.hs | 61 |
1 files changed, 33 insertions, 28 deletions
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 - ) |