diff options
| -rw-r--r-- | Annex/Init.hs | 4 | ||||
| -rw-r--r-- | Annex/WorkTree.hs | 36 | ||||
| -rw-r--r-- | Database/Keys.hs | 32 | ||||
| -rw-r--r-- | Database/Keys/SQL.hs | 12 | ||||
| -rw-r--r-- | Upgrade/V5.hs | 3 |
5 files changed, 52 insertions, 35 deletions
diff --git a/Annex/Init.hs b/Annex/Init.hs index 9e0361daf..5aff4cf39 100644 --- a/Annex/Init.hs +++ b/Annex/Init.hs @@ -31,6 +31,7 @@ import Annex.Version import Annex.Difference import Annex.UUID import Annex.Link +import Annex.WorkTree import Config import Annex.Direct import Annex.AdjustedBranch @@ -39,7 +40,6 @@ import Annex.Hook import Annex.InodeSentinal import Upgrade import Annex.Perms -import qualified Database.Keys import Utility.UserInfo #ifndef mingw32_HOST_OS import Utility.FileMode @@ -90,7 +90,7 @@ initialize' mversion = do setVersion (fromMaybe defaultVersion mversion) whenM versionSupportsUnlockedPointers $ do configureSmudgeFilter - Database.Keys.scanAssociatedFiles + scanUnlockedFiles v <- checkAdjustedClone case v of NeedUpgradeForAdjustedClone -> diff --git a/Annex/WorkTree.hs b/Annex/WorkTree.hs index b2c8cb7f3..fe42ab726 100644 --- a/Annex/WorkTree.hs +++ b/Annex/WorkTree.hs @@ -1,6 +1,6 @@ {- git-annex worktree files - - - Copyright 2013-2015 Joey Hess <id@joeyh.name> + - Copyright 2013-2016 Joey Hess <id@joeyh.name> - - Licensed under the GNU GPL version 3 or higher. -} @@ -12,6 +12,13 @@ import Annex.Link import Annex.CatFile import Annex.Version import Config +import qualified Git.Ref +import qualified Git.Branch +import qualified Git.LsTree +import qualified Git.Types +import Database.Types +import qualified Database.Keys +import qualified Database.Keys.SQL {- Looks up the key corresponding to an annexed file in the work tree, - by examining what the file links to. @@ -41,3 +48,30 @@ whenAnnexed a file = ifAnnexed file (a file) (return Nothing) ifAnnexed :: FilePath -> (Key -> Annex a) -> Annex a -> Annex a ifAnnexed file yes no = maybe no yes =<< lookupFile file + +{- Find all unlocked files and update the keys database for them. + - + - This is expensive, and so normally the associated files are updated + - incrementally when changes are noticed. So, this only needs to be done + - when initializing/upgrading a v6 mode repository. + -} +scanUnlockedFiles :: Annex () +scanUnlockedFiles = whenM (isJust <$> inRepo Git.Branch.current) $ + Database.Keys.runWriter $ \h -> do + showSideAction "scanning for unlocked files" + liftIO $ Database.Keys.SQL.dropAllAssociatedFiles h + (l, cleanup) <- inRepo $ Git.LsTree.lsTree Git.Ref.headRef + forM_ l $ \i -> + when (isregfile i) $ + maybe noop (add h i) + =<< catKey (Git.LsTree.sha i) + liftIO $ void cleanup + where + isregfile i = case Git.Types.toBlobType (Git.LsTree.mode i) of + Just Git.Types.FileBlob -> True + Just Git.Types.ExecutableBlob -> True + _ -> False + add h i k = liftIO $ Database.Keys.SQL.addAssociatedFileFast + (toIKey k) + (Git.LsTree.file i) + h diff --git a/Database/Keys.hs b/Database/Keys.hs index 3d9330e90..77f4f6382 100644 --- a/Database/Keys.hs +++ b/Database/Keys.hs @@ -14,11 +14,11 @@ module Database.Keys ( getAssociatedFiles, getAssociatedKey, removeAssociatedFile, - scanAssociatedFiles, storeInodeCaches, addInodeCaches, getInodeCaches, removeInodeCaches, + runWriter, ) where import qualified Database.Keys.SQL as SQL @@ -36,11 +36,7 @@ import Annex.InodeSentinal import qualified Git.Types import qualified Git.LsTree import qualified Git.Branch -import Git.Ref import Git.FilePath -import Annex.CatFile - -import Database.Esqueleto hiding (Key) {- Runs an action that reads from the database. - @@ -168,32 +164,6 @@ getAssociatedKey = map fromIKey <$$> runReaderIO . SQL.getAssociatedKey removeAssociatedFile :: Key -> TopFilePath -> Annex () removeAssociatedFile k = runWriterIO . SQL.removeAssociatedFile (toIKey k) -{- Find all unlocked associated files. This is expensive, and so normally - - the associated files are updated incrementally when changes are noticed. -} -scanAssociatedFiles :: Annex () -scanAssociatedFiles = whenM (isJust <$> inRepo Git.Branch.current) $ - runWriter $ \h -> do - showSideAction "scanning for unlocked files" - dropallassociated h - (l, cleanup) <- inRepo $ Git.LsTree.lsTree headRef - forM_ l $ \i -> - when (isregfile i) $ - maybe noop (add h i) - =<< catKey (Git.LsTree.sha i) - liftIO $ void cleanup - where - dropallassociated h = liftIO $ flip SQL.queueDb h $ - delete $ from $ \(_r :: SqlExpr (Entity SQL.Associated)) -> - return () - isregfile i = case Git.Types.toBlobType (Git.LsTree.mode i) of - Just Git.Types.FileBlob -> True - Just Git.Types.ExecutableBlob -> True - _ -> False - add h i k = liftIO $ flip SQL.queueDb h $ - void $ insertUnique $ SQL.Associated - (toIKey k) - (toSFilePath $ getTopFilePath $ Git.LsTree.file i) - {- Stats the files, and stores their InodeCaches. -} storeInodeCaches :: Key -> [FilePath] -> Annex () storeInodeCaches k fs = withTSDelta $ \d -> diff --git a/Database/Keys/SQL.hs b/Database/Keys/SQL.hs index 88e6ba2dc..77c1e4429 100644 --- a/Database/Keys/SQL.hs +++ b/Database/Keys/SQL.hs @@ -68,6 +68,18 @@ addAssociatedFile ik f = queueDb $ do where af = toSFilePath (getTopFilePath f) +-- Does not remove any old association for a file, but less expensive +-- than addAssociatedFile. Calling dropAllAssociatedFiles first and then +-- this is an efficient way to update all associated files. +addAssociatedFileFast :: IKey -> TopFilePath -> WriteHandle -> IO () +addAssociatedFileFast ik f = queueDb $ void $ insertUnique $ Associated ik af + where + af = toSFilePath (getTopFilePath f) + +dropAllAssociatedFiles :: WriteHandle -> IO () +dropAllAssociatedFiles = queueDb $ + delete $ from $ \(_r :: SqlExpr (Entity Associated)) -> return () + {- Note that the files returned were once associated with the key, but - some of them may not be any longer. -} getAssociatedFiles :: IKey -> ReadHandle -> IO [TopFilePath] diff --git a/Upgrade/V5.hs b/Upgrade/V5.hs index e5ca505ac..a05f2e051 100644 --- a/Upgrade/V5.hs +++ b/Upgrade/V5.hs @@ -15,6 +15,7 @@ import Annex.Link import Annex.Direct import Annex.Content import Annex.CatFile +import Annex.WorkTree import qualified Database.Keys import qualified Annex.Content.Direct as Direct import qualified Git @@ -31,7 +32,7 @@ upgrade :: Bool -> Annex Bool upgrade automatic = do unless automatic $ showAction "v5 to v6" - Database.Keys.scanAssociatedFiles + scanUnlockedFiles whenM isDirect $ do {- Direct mode makes the same tradeoff of using less disk - space, with less preservation of old versions of files |