diff --git a/Annex/WorkTree.hs b/Annex/WorkTree.hs index 8d09adf7a8..b9d45b483d 100644 --- a/Annex/WorkTree.hs +++ b/Annex/WorkTree.hs @@ -70,29 +70,27 @@ ifAnnexed file yes no = maybe no yes =<< lookupKey file {- Find all annexed 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 repository. + - - Also, the content for an unlocked file may already be present as - an annex object. If so, populate the pointer file with it. - But if worktree file does not have a pointer file's content, it is left - as-is. - - - - Normally the keys database is updated incrementally when changes are - - noticed. For an initial scan, this is faster than that incremental - - update. -} scanAnnexedFiles :: Annex () -scanAnnexedFiles = whenM (inRepo Git.Ref.headExists <&&> not <$> isBareRepo) $ - Database.Keys.runWriter' (Just reconciler) (const noop) +scanAnnexedFiles = whenM (inRepo Git.Ref.headExists <&&> not <$> isBareRepo) $ do + g <- Annex.gitRepo + Database.Keys.runWriter $ + liftIO . Database.Keys.SQL.dropAllAssociatedFiles + (l, cleanup) <- inRepo $ Git.LsTree.lsTree + Git.LsTree.LsTreeRecursive + (Git.LsTree.LsTreeLong True) + Git.Ref.headRef + catObjectStreamLsTree l want g go + liftIO $ void cleanup where - reconciler dbh = do - g <- Annex.gitRepo - liftIO $ Database.Keys.SQL.dropAllAssociatedFiles dbh - (l, cleanup) <- inRepo $ Git.LsTree.lsTree - Git.LsTree.LsTreeRecursive - (Git.LsTree.LsTreeLong True) - Git.Ref.headRef - catObjectStreamLsTree l want g (go dbh) - liftIO $ void cleanup - -- Want to process symlinks, and regular files. want i = case Git.Types.toTreeItemType (Git.LsTree.mode i) of Just Git.Types.TreeSymlink -> Just (i, False) @@ -105,16 +103,17 @@ scanAnnexedFiles = whenM (inRepo Git.Ref.headExists <&&> not <$> isBareRepo) $ Just n | n < maxPointerSz -> Just (i, True) _ -> Nothing - go dbh getnext = liftIO getnext >>= \case + go getnext = liftIO getnext >>= \case Just ((i, isregfile), Just c) -> do - maybe noop (add i isregfile dbh) + maybe noop (add i isregfile) (parseLinkTargetOrPointer (L.toStrict c)) - go dbh getnext + go getnext _ -> return () - add i isregfile dbh k = do + add i isregfile k = do let tf = Git.LsTree.file i - liftIO $ Database.Keys.SQL.addAssociatedFileFast k tf dbh + Database.Keys.runWriter $ + liftIO . Database.Keys.SQL.addAssociatedFileFast k tf whenM (pure isregfile <&&> inAnnex k) $ do f <- fromRepo $ fromTopFilePath tf liftIO (isPointerFile f) >>= \case diff --git a/Database/Keys.hs b/Database/Keys.hs index 778a0af1ac..8b6edd80fe 100644 --- a/Database/Keys.hs +++ b/Database/Keys.hs @@ -23,7 +23,6 @@ module Database.Keys ( removeInodeCache, isInodeKnown, runWriter, - runWriter', ) where import qualified Database.Keys.SQL as SQL @@ -74,7 +73,7 @@ runReader a = do v <- a (SQL.ReadHandle qh) return (v, st) go DbClosed = do - st' <- openDb True Nothing DbClosed + st' <- openDb True DbClosed v <- case st' of (DbOpen qh) -> a (SQL.ReadHandle qh) _ -> return mempty @@ -88,15 +87,7 @@ runReaderIO a = runReader (liftIO . a) - - The database is created if it doesn't exist yet. -} runWriter :: (SQL.WriteHandle -> Annex ()) -> Annex () -runWriter = runWriter' Nothing - -runWriterIO :: (SQL.WriteHandle -> IO ()) -> Annex () -runWriterIO a = runWriter (liftIO . a) - -{- When a reconcile action is passed, it is run by reconcileStaged instead - - of its usual scan, and must update the database in the same way. -} -runWriter' :: Maybe (SQL.WriteHandle -> Annex ()) -> (SQL.WriteHandle -> Annex ()) -> Annex () -runWriter' reconciler a = do +runWriter a = do h <- Annex.getRead Annex.keysdbhandle withDbState h go where @@ -104,12 +95,15 @@ runWriter' reconciler a = do v <- a (SQL.WriteHandle qh) return (v, st) go st = do - st' <- openDb False reconciler st + st' <- openDb False st v <- case st' of DbOpen qh -> a (SQL.WriteHandle qh) _ -> error "internal" return (v, st') +runWriterIO :: (SQL.WriteHandle -> IO ()) -> Annex () +runWriterIO a = runWriter (liftIO . a) + {- Opens the database, creating it if it doesn't exist yet. - - Multiple readers and writers can have the database open at the same @@ -118,10 +112,10 @@ runWriter' reconciler a = do - the database doesn't exist yet, one caller wins the lock and - can create it undisturbed. -} -openDb :: Bool -> (Maybe (SQL.WriteHandle -> Annex ())) -> DbState -> Annex DbState -openDb _ _ st@(DbOpen _) = return st -openDb False _ DbUnavailable = return DbUnavailable -openDb forwrite reconciler _ = catchPermissionDenied permerr $ withExclusiveLock gitAnnexKeysDbLock $ do +openDb :: Bool -> DbState -> Annex DbState +openDb _ st@(DbOpen _) = return st +openDb False DbUnavailable = return DbUnavailable +openDb forwrite _ = catchPermissionDenied permerr $ withExclusiveLock gitAnnexKeysDbLock $ do dbdir <- fromRepo gitAnnexKeysDb let db = dbdir P. "db" dbexists <- liftIO $ R.doesPathExist db @@ -139,7 +133,7 @@ openDb forwrite reconciler _ = catchPermissionDenied permerr $ withExclusiveLock open db = do qh <- liftIO $ H.openDbQueue H.MultiWriter db SQL.containedTable - reconcileStaged qh reconciler + reconcileStaged qh return $ DbOpen qh {- Closes the database if it was open. Any writes will be flushed to it. @@ -229,8 +223,8 @@ isInodeKnown i s = or <$> runReaderIO ((:[]) <$$> SQL.isInodeKnown i s) - So when using getAssociatedFiles, have to make sure the file still - is an associated file. -} -reconcileStaged :: H.DbQueue -> Maybe (SQL.WriteHandle -> Annex ()) -> Annex () -reconcileStaged qh mreconciler = do +reconcileStaged :: H.DbQueue -> Annex () +reconcileStaged qh = do gitindex <- inRepo currentIndexFile indexcache <- fromRawFilePath <$> fromRepo gitAnnexKeysDbIndexCache withTSDelta (liftIO . genInodeCache gitindex) >>= \case @@ -252,21 +246,12 @@ reconcileStaged qh mreconciler = do go cur indexcache (Just newtree) = do oldtree <- getoldtree when (oldtree /= newtree) $ do - case mreconciler of - Just reconciler -> - reconciler (SQL.WriteHandle qh) - Nothing -> noop g <- Annex.gitRepo - void $ catstream $ \mdfeeder -> do - case mreconciler of - Nothing -> void $ updatetodiff g - (Just (fromRef oldtree)) - (fromRef newtree) - (procdiff mdfeeder) - Just _ -> void $ updatetodiff g - Nothing "--staged" - (procdiff mdfeeder) - + void $ catstream $ \mdfeeder -> + void $ updatetodiff g + (Just (fromRef oldtree)) + (fromRef newtree) + (procdiff mdfeeder) liftIO $ writeFile indexcache $ showInodeCache cur -- Storing the tree in a ref makes sure it does not -- get garbage collected, and is available to diff