import Annex.Branch (UnmergedBranches(..), getBranch)
import Types.RepoSize
import qualified Database.RepoSize as Db
+import Logs
import Logs.Location
import Logs.UUID
import Git.Types (Sha)
+import Git.FilePath
+import Git.CatFile
+import qualified Git.DiffTree as DiffTree
import Control.Concurrent
+import Control.Concurrent.Async
import qualified Data.Map.Strict as M
+import qualified Data.Set as S
{- Gets the repo size map. Cached for speed. -}
getRepoSizes :: Annex (M.Map UUID RepoSize)
currbranchsha <- getBranch
if oldbranchsha == currbranchsha
then calcJournalledRepoSizes oldsizemap oldbranchsha
- else do
- -- XXX todo incremental update by diffing
- -- from old to new branch.
- calculatefromscratch h
+ else incrementalupdate h oldsizemap oldbranchsha currbranchsha
liftIO $ putMVar rsv (Just sizemap)
return sizemap
liftIO $ Db.setRepoSizes h sizemap branchsha
calcJournalledRepoSizes sizemap branchsha
+ incrementalupdate h oldsizemap oldbranchsha currbranchsha = do
+ (sizemap, branchsha) <- diffBranchRepoSizes oldsizemap oldbranchsha currbranchsha
+ liftIO $ Db.setRepoSizes h sizemap branchsha
+ calcJournalledRepoSizes sizemap branchsha
+
setup = Db.openDb
cleanup = Db.closeDb
- branch commit that was used.
-
- The map includes the UUIDs of all known repositories, including
- - repositories that are empty.
+ - repositories that are empty. But clusters are not included.
-
- Note that private repositories, which do not get recorded in
- the git-annex branch, will have 0 size. journalledRepoSizes
-> Sha
-> Annex (M.Map UUID RepoSize)
calcJournalledRepoSizes startmap branchsha =
- overLocationLogsJournal startmap branchsha accumsizes Nothing
+ overLocationLogsJournal startmap branchsha
+ (\k v m -> pure (accumRepoSizes k v m))
+ Nothing
+
+{- Incremental update by diffing. -}
+diffBranchRepoSizes :: M.Map UUID RepoSize -> Sha -> Sha -> Annex (M.Map UUID RepoSize, Sha)
+diffBranchRepoSizes oldsizemap oldbranchsha newbranchsha = do
+ g <- Annex.gitRepo
+ catObjectStream g $ \feeder closer reader -> do
+ (l, cleanup) <- inRepo $
+ DiffTree.diffTreeRecursive oldbranchsha newbranchsha
+ feedtid <- liftIO $ async $ do
+ forM_ l $ feedpairs feeder
+ closer
+ newsizemap <- readpairs 500000 reader oldsizemap Nothing
+ liftIO $ wait feedtid
+ ifM (liftIO cleanup)
+ ( return (newsizemap, newbranchsha)
+ , return (oldsizemap, oldbranchsha)
+ )
where
- accumsizes k (newlocs, removedlocs) m = return $
- let m' = foldl' (flip $ M.alter $ addKeyRepoSize k) m newlocs
- in foldl' (flip $ M.alter $ removeKeyRepoSize k) m' removedlocs
+ feedpairs feeder ti =
+ let f = getTopFilePath (DiffTree.file ti)
+ in case extLogFileKey locationLogExt f of
+ Nothing -> noop
+ Just k -> do
+ feeder (k, DiffTree.srcsha ti)
+ feeder (k, DiffTree.dstsha ti)
+
+ readpairs n reader sizemap Nothing = liftIO reader >>= \case
+ Just (_k, oldcontent) -> readpairs n reader sizemap (Just oldcontent)
+ Nothing -> return sizemap
+ readpairs n reader sizemap (Just oldcontent) = liftIO reader >>= \case
+ Just (k, newcontent) ->
+ let prevlog = parselog oldcontent
+ currlog = parselog newcontent
+ newlocs = S.difference currlog prevlog
+ removedlocs = S.difference prevlog currlog
+ !sizemap' = accumRepoSizes k (newlocs, removedlocs) sizemap
+ in do
+ n' <- countdownToMessage n $
+ showSideAction "calculating repository sizes"
+ readpairs n' reader sizemap' Nothing
+ Nothing -> return sizemap
+ parselog = maybe mempty (S.fromList . parseLoggedLocationsWithoutClusters)
import Control.Concurrent
import qualified Data.Map.Strict as M
+import qualified Data.Set as S
updateRepoSize :: UUID -> Key -> LogStatus -> Annex ()
updateRepoSize u k s = do
Nothing -> Nothing
where
ksz = fromMaybe 0 $ fromKey keySize k
+
+accumRepoSizes :: Key -> (S.Set UUID, S.Set UUID) -> M.Map UUID RepoSize -> M.Map UUID RepoSize
+accumRepoSizes k (newlocs, removedlocs) sizemap =
+ let !sizemap' = foldl' (flip $ M.alter $ addKeyRepoSize k) sizemap newlocs
+ in foldl' (flip $ M.alter $ removeKeyRepoSize k) sizemap' removedlocs
dbwriter dbchanged n catreader = liftIO catreader >>= \case
Just (ka, content) -> do
changed <- ka (parseLinkTargetOrPointerLazy =<< content)
- !n' <- countdownToMessage n
+ n' <- countdownToMessage n $
+ showSideAction "scanning for annexed files"
dbwriter (dbchanged || changed) n' catreader
Nothing -> return dbchanged
- -- When the diff is large, the scan can take a while,
- -- so let the user know what's going on.
- countdownToMessage n
- | n < 1 = return 0
- | n == 1 = do
- showSideAction "scanning for annexed files"
- return 0
- | otherwise = return (pred n)
-
-- How large is large? Too large and there will be a long
-- delay before the message is shown; too short and the message
-- will clutter things up unnecessarily. It's uncommon for 1000
{- The pathname of the location log file for a given key. -}
locationLogFile :: GitConfig -> Key -> RawFilePath
locationLogFile config key =
- branchHashDir config key P.</> keyFile key <> ".log"
+ branchHashDir config key P.</> keyFile key <> locationLogExt
+
+locationLogExt :: S.ByteString
+locationLogExt = ".log"
{- The filename of the url log for a given key. -}
urlLogFile :: GitConfig -> Key -> RawFilePath
overLocationLogs,
overLocationLogs',
overLocationLogsJournal,
+ parseLoggedLocations,
+ parseLoggedLocationsWithoutClusters,
) where
import Annex.Common
loggedLocationsRef :: Ref -> Annex [UUID]
loggedLocationsRef ref = map (toUUID . fromLogInfo) . getLog <$> catObject ref
-{- Parses the content of a log file and gets the locations in it. -}
+{- Parses the content of a log file and gets the locations in it.
+ -
+ - Adds the UUIDs of any clusters whose nodes are in the list.
+ -}
parseLoggedLocations :: Clusters -> L.ByteString -> [UUID]
parseLoggedLocations clusters =
addClusterUUIDs clusters . parseLoggedLocationsWithoutClusters
clusters <- getClusters
return $ addClusterUUIDs clusters locs
--- Add UUIDs of any clusters whose nodes are in the list.
addClusterUUIDs :: Clusters -> [UUID] -> [UUID]
addClusterUUIDs clusters locs
| M.null clustermap = locs
- Licensed under the GNU AGPL version 3 or higher.
-}
-{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, CPP #-}
+{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, BangPatterns, CPP #-}
module Messages (
showStartMessage,
prompt,
mkPrompter,
sanitizeTopLevelExceptionMessages,
+ countdownToMessage,
) where
import Control.Concurrent
go e = do
hPutStrLn stderr $ safeOutput $ toplevelMsg (show e)
exitWith $ ExitFailure 1
+
+{- Used to only run an action that displays a message after the specified
+ - number of steps. This is useful when performing an action that can
+ - sometimes take a long time, but often does not.
+ -}
+countdownToMessage :: Int -> Annex () -> Annex Int
+countdownToMessage n showmsg
+ | n < 1 = return 0
+ | n == 1 = do
+ showmsg
+ return 0
+ | otherwise = do
+ let !n' = pred n
+ return n'
## work notes
-* Implement [[track_free_space_in_repos_via_git-annex_branch]]:
-
- * updateRepoSizes incrementally when the git-annex branch sha in the
- database is older than the current git-annex branch. Diff from old to
- new branch to efficiently update.
-
- Note ideas in above todo about doing this at git-annex branch merge
- time to reuse the git diff done there.
+* Concurrency issues with RepoSizes calculation and balanced content:
* What if 2 concurrent threads are considering sending two different
keys to a repo at the same time. It can hold either but not both.
- It should avoid sending both in this situation. (Also discussed in
- above todo)
+ It should avoid sending both in this situation.
* There can also be a race with 2 concurrent threads where one just
finished sending to a repo, but has not yet updated the location log.
* Balanced preferred content basic implementation, including --rebalance
option.
+* Implemented [[track_free_space_in_repos_via_git-annex_branch]]
## completed items for August's work on git-annex proxy support for exporttre
--- /dev/null
+When git-annex merges a remote into the git-annex branch, it uses
+a CatFileHandle, making a query get the contents of each file in the
+diff. It would be faster for it to use catObjectStream.
+[[!commit d010ab04be5a8d74fe85a2fa27a853784d1f9009]] saw a 2x-16x
+improvement to a similar process.
+
+Also, Database.ContentIdentifier.updateFromLog,
+Database.ImportFeed.updateFromLog, and Annex.RepoSize.diffBranchRepoSizes
+each do a similar diff and cat-file to update information cached from the
+git-annex branch into a database. (diffBranchRepoSizes does use
+catObjectStream, the others don't.)
+
+It seems like it might be possible to
+make merging the git-annex branch do these updates in passing, and reduce
+the overhead of diff and cat-file 4x. --[[Joey]]
because the logs they diff are less often used, and the work is only
done when relevant commands are run.
+(Opened [[todo/optimise_git-annex_branch_merge_and_database_updates]]
+about that possibility.)
+
## concurrency
Suppose a repository is almost full. Two concurrent threads or processes
`sizeOfUploadsInProgressToRemote r` similarly.
[[!tag projects/openneuro]]
+
+> Current status: This is implemented, but concurrency issues remain.
+> --[[Joey]]
projects / git-annex.git / commitdiff