From cd3a2b023af0220a6e6866cc8e112b1b26c658b9 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 4 Mar 2019 17:50:41 -0400 Subject: [PATCH] initial try at using storeExportWithContentIdentifier Untested, and I'm not sure about the locking of the ContentIdentifier db. --- Annex/LockFile.hs | 12 +++- Database/ContentIdentifier.hs | 8 +-- Database/Export.hs | 4 +- Remote/Helper/ExportImport.hs | 112 ++++++++++++++++++++++------------ Remote/List.hs | 5 +- doc/todo/import_tree.mdwn | 11 +++- 6 files changed, 96 insertions(+), 56 deletions(-) diff --git a/Annex/LockFile.hs b/Annex/LockFile.hs index 66a53ebb82..f8389711b7 100644 --- a/Annex/LockFile.hs +++ b/Annex/LockFile.hs @@ -14,6 +14,7 @@ module Annex.LockFile ( fromLockCache, withSharedLock, withExclusiveLock, + takeExclusiveLock, tryExclusiveLock, ) where @@ -77,11 +78,18 @@ withSharedLock getlockfile a = debugLocks $ do {- Runs an action with an exclusive lock held. If the lock is already - held, blocks until it becomes free. -} withExclusiveLock :: (Git.Repo -> FilePath) -> Annex a -> Annex a -withExclusiveLock getlockfile a = debugLocks $ do +withExclusiveLock getlockfile a = bracket + (takeExclusiveLock getlockfile) + (liftIO . dropLock) + (const a) + +{- Takes an exclusive lock, blocking until it's free. -} +takeExclusiveLock :: (Git.Repo -> FilePath) -> Annex LockHandle +takeExclusiveLock getlockfile = debugLocks $ do lockfile <- fromRepo getlockfile createAnnexDirectory $ takeDirectory lockfile mode <- annexFileMode - bracket (lock mode lockfile) (liftIO . dropLock) (const a) + lock mode lockfile where #ifndef mingw32_HOST_OS lock mode = noUmask mode . lockExclusive (Just mode) diff --git a/Database/ContentIdentifier.hs b/Database/ContentIdentifier.hs index 3615adec67..d63454998c 100644 --- a/Database/ContentIdentifier.hs +++ b/Database/ContentIdentifier.hs @@ -20,6 +20,7 @@ module Database.ContentIdentifier ( closeDb, flushDbQueue, recordContentIdentifier, + getContentIdentifiers, getContentIdentifierKeys, ContentIdentifiersId, ) where @@ -82,11 +83,8 @@ recordContentIdentifier h u cid k = queueDb h $ do getContentIdentifiers :: ContentIdentifierHandle -> UUID -> Key -> IO [ContentIdentifier] getContentIdentifiers (ContentIdentifierHandle h) u k = H.queryDbQueue h $ do - l <- selectList - [ ContentIdentifiersCid ==. cid - , ContentIdentifiersKey ==. toSKey k - ] [] - return $ map (ContentIdentifiersCid . entityVal) l + l <- selectList [ContentIdentifiersKey ==. toSKey k] [] + return $ map (contentIdentifiersCid . entityVal) l getContentIdentifierKeys :: ContentIdentifierHandle -> UUID -> ContentIdentifier -> IO [Key] getContentIdentifierKeys (ContentIdentifierHandle h) u cid = diff --git a/Database/Export.hs b/Database/Export.hs index cbc8a51d0b..cdf384ba39 100644 --- a/Database/Export.hs +++ b/Database/Export.hs @@ -163,9 +163,9 @@ getExportedLocation (ExportHandle h _) k = H.queryDbQueue h $ do - Note that this does not see recently queued changes. -} getExportedKey :: ExportHandle -> ExportLocation -> IO [Key] -getExportedKey ExportHandle h _) el = H.queryDbQueue h $ do +getExportedKey (ExportHandle h _) el = H.queryDbQueue h $ do l <- selectList [ExportedFile ==. ef] [] - return $ map (fromSKey . exportedKey . entityVal) l + return $ map (fromIKey . exportedKey . entityVal) l where ef = toSFilePath (fromExportLocation el) diff --git a/Remote/Helper/ExportImport.hs b/Remote/Helper/ExportImport.hs index d281562fbf..20d9df7f91 100644 --- a/Remote/Helper/ExportImport.hs +++ b/Remote/Helper/ExportImport.hs @@ -5,7 +5,7 @@ - Licensed under the GNU GPL version 3 or higher. -} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleInstances, FlexibleContexts #-} module Remote.Helper.ExportImport where @@ -15,9 +15,11 @@ import Types.Backend import Types.Key import Backend import Remote.Helper.Encryptable (isEncrypted) -import Database.Export +import qualified Database.Export as Export +import qualified Database.ContentIdentifier as ContentIdentifier import Annex.Export import Annex.Import +import Annex.LockFile import Config import Git.Types (fromRef) import Logs.Export @@ -91,51 +93,81 @@ adjustExportImportRemoteType rt = rt { setup = setup' } then giveup "cannot enable importtree=yes without also enabling exporttree=yes" else setup rt st mu cp c gc --- | If the remote is importSupported, and importtree=yes, adjust the --- remote to be an import. +-- | Adjust a remote to support exporttree=yes and importree=yes. -- --- (This relies on all import remotes also being export remotes, --- so adjustExportable will adjust the remote actions to use the --- exported/imported tree.) -adjustImportable :: Remote -> Annex Remote -adjustImportable r - | importTree (config r) = - ifM (isExportSupported r) - ( return r - , notimport - ) - | otherwise = notimport - where - notimport = return $ r - { importActions = importUnsupported - , remotetype = (remotetype r) - { importSupported = importUnsupported - } - } - --- | If the remote is exportSupported, and exporttree=yes, adjust the --- remote to be an export. -adjustExportable :: Remote -> Annex Remote -adjustExportable r = case M.lookup "exporttree" (config r) of - Nothing -> notexport +-- Note that all remotes with importree=yes also have exporttree=yes. +adjustExportImport :: Remote -> Annex Remote +adjustExportImport r = case M.lookup "exporttree" (config r) of + Nothing -> return $ notexport r Just c -> case yesNo c of Just True -> ifM (isExportSupported r) - ( isexport - , notexport + ( do + exportdb <- Export.openDb (uuid r) + r' <- isexport exportdb + if importTree (config r) + then isimport r' exportdb + else return r' + , return $ notexport r ) - Just False -> notexport + Just False -> return $ notexport r Nothing -> do warning $ "bad exporttree value for " ++ name r ++ ", assuming not an export" - notexport + return $ notexport r where - notexport = return $ r + notexport r' = notimport r' { exportActions = exportUnsupported - , remotetype = (remotetype r) + , remotetype = (remotetype r') { exportSupported = exportUnsupported } } - isexport = do - db <- openDb (uuid r) + + notimport r' = r' + { importActions = importUnsupported + , remotetype = (remotetype r') + { importSupported = importUnsupported + } + } + + isimport r' exportdb = do + lcklckv <- liftIO newEmptyTMVarIO + dbtv <- liftIO newEmptyTMVarIO + let store f k loc p = do + -- Only open the database once it's needed, since + -- we have to take an exclusive write lock. + -- The write lock will remain held while the + -- process is running. + db <- liftIO (atomically (tryReadTMVar dbtv)) >>= \case + Just (db, _lck) -> return db + -- let only one thread take the lock + Nothing -> ifM (liftIO $ atomically $ tryPutTMVar lcklckv ()) + ( do + lck <- takeExclusiveLock gitAnnexContentIdentifierLock + db <- ContentIdentifier.openDb + liftIO $ atomically (putTMVar dbtv (db, lck)) + return db + -- loser waits for winner to open + -- the db and can then also use its + -- handle + , liftIO $ fst <$> atomically (readTMVar dbtv) + ) + + ks <- liftIO $ Export.getExportedKey exportdb loc + oldcids <- liftIO $ concat + <$> mapM (ContentIdentifier.getContentIdentifiers db (uuid r')) ks + storeExportWithContentIdentifier (importActions r') f k loc oldcids p >>= \case + Nothing -> return False + Just newcid -> do + liftIO $ ContentIdentifier.recordContentIdentifier db (uuid r') newcid k + -- TODO update git-annex branch + return True + + return $ r' + { exportActions = (exportActions r') + { storeExport = store + } + } + + isexport db = do updateflag <- liftIO $ newTVarIO Nothing -- When multiple threads run this, all except the first @@ -163,13 +195,13 @@ adjustExportable r = case M.lookup "exporttree" (config r) of let getexportlocs = \k -> do bracket startupdateonce doneupdateonce $ \updatenow -> when updatenow $ - updateExportTreeFromLog db >>= \case - ExportUpdateSuccess -> return () - ExportUpdateConflict -> do + Export.updateExportTreeFromLog db >>= \case + Export.ExportUpdateSuccess -> return () + Export.ExportUpdateConflict -> do warnExportConflict r liftIO $ atomically $ writeTVar exportinconflict True - liftIO $ getExportTree db k + liftIO $ Export.getExportTree db k return $ r -- Storing a key on an export could be implemented, diff --git a/Remote/List.hs b/Remote/List.hs index 63fdb72f0e..708b3cc56f 100644 --- a/Remote/List.hs +++ b/Remote/List.hs @@ -106,10 +106,7 @@ remoteGen m t g = do let c = fromMaybe M.empty $ M.lookup u m generate t g u c gc >>= \case Nothing -> return Nothing - Just r -> do - r' <- adjustImportable (adjustReadOnly (addHooks r)) - r'' <- adjustExportable r' - return $ Just r'' + Just r -> Just <$> adjustExportImport (adjustReadOnly (addHooks r)) {- Updates a local git Remote, re-reading its git config. -} updateRemote :: Remote -> Annex (Maybe Remote) diff --git a/doc/todo/import_tree.mdwn b/doc/todo/import_tree.mdwn index 2a2334f370..f713a78bbc 100644 --- a/doc/todo/import_tree.mdwn +++ b/doc/todo/import_tree.mdwn @@ -10,12 +10,17 @@ this. ## implementation notes +* Should the ContentIdentifier db be multiwriter? It would simplify + the situation with the long-lived lock of it in adjustExportImport + +* fix TODO in adjustExportImport + +* Test export to importtree=yes remote and make sure it uses + storeExportWithContentIdentifier correctly. + * Need to support annex-tracking-branch configuration, which documentation says makes git-annex sync and assistant do imports. -* export needs to use storeExportWithContentIdentifierM for importtree=yes - remotes - * Database.ContentIdentifier needs a way to update the database with information coming from the git-annex branch. This will allow multiple clones to import from the same remote, and share content identifier