refactor

diff --git a/Annex/Init.hs b/Annex/Init.hs
index 9e0361daf296410c5e6de8b7b39ae4f746e845eb..5aff4cf39874d82c644dd662cfa0872ec055f025 100644 (file)
--- 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 b2c8cb7f371b50767854b595303fa8b63b571da0..fe42ab726bda530faacd5c7ba2593622312c91ca 100644 (file)
--- 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 3d9330e90e73d9fa9b8667c2c21a8d83f5190c2f..77f4f6382edc14eb4224820e235022f0ff343c47 100644 (file)
--- 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 88e6ba2dcb366ce8177c5fcbf38c9994df57c42b..77c1e4429c9c5c364a241e4c05d31ae6a468b0ac 100644 (file)
--- 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 e5ca505ac0c15749252a30a7d7317dbd4a32fc89..a05f2e05122af87f03c639d8e76006a82a09a185 100644 (file)
--- 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