bcf276655c
fsck already special-cased dead keys to make --all not report errors with them, and it makes sense to also expand that to whereis. I think it makes sense for dead keys to be skipped by all uses of --all, so mistakes can be completely forgotten about and not come back to haunt us. The speed impact of testing if the key is dead is negligible for fsck and whereis, since they use the location log anyway and it gets cached. This does slow down a few commands that support --all, in particular metadata --all runs around 2x as slow. I don't think metadata --all is often used though. It might slow down copy/move/mirror --all and get --all. log --all is not affected (does not use the normal --all machinery). Dead keys will still be processed by --incomplete, --branch, --failed, and --key. Although it would be unlikely for a dead key to ave in incomplete or failed transfer. It seems to make perfect sense for --branch to process keys on the branch, even if dead. (fsck's special-casing of dead keys was left in, so if one of these options causes a dead key to be fscked, there will be a nice message.) This commit was supported by the NSF-funded DataLad project.
135 lines
4 KiB
Haskell
135 lines
4 KiB
Haskell
{-# LANGUAGE BangPatterns #-}
|
|
|
|
{- git-annex location log
|
|
-
|
|
- git-annex keeps track of which repositories have the contents of annexed
|
|
- files.
|
|
-
|
|
- Repositories record their UUID and the date when they --get or --drop
|
|
- a value.
|
|
-
|
|
- Copyright 2010-2015 Joey Hess <id@joeyh.name>
|
|
-
|
|
- Licensed under the GNU GPL version 3 or higher.
|
|
-}
|
|
|
|
module Logs.Location (
|
|
LogStatus(..),
|
|
logStatus,
|
|
logChange,
|
|
loggedLocations,
|
|
loggedLocationsHistorical,
|
|
loggedLocationsRef,
|
|
isKnownKey,
|
|
checkDead,
|
|
setDead,
|
|
loggedKeys,
|
|
loggedKeysFor,
|
|
) where
|
|
|
|
import Annex.Common
|
|
import qualified Annex.Branch
|
|
import Logs
|
|
import Logs.Presence
|
|
import Annex.UUID
|
|
import Annex.CatFile
|
|
import Git.Types (RefDate, Ref)
|
|
import qualified Annex
|
|
|
|
import Data.Time.Clock
|
|
import qualified Data.ByteString.Lazy.Char8 as L
|
|
|
|
{- Log a change in the presence of a key's value in current repository. -}
|
|
logStatus :: Key -> LogStatus -> Annex ()
|
|
logStatus key s = do
|
|
u <- getUUID
|
|
logChange key u s
|
|
|
|
{- Log a change in the presence of a key's value in a repository. -}
|
|
logChange :: Key -> UUID -> LogStatus -> Annex ()
|
|
logChange = logChange' logNow
|
|
|
|
logChange' :: (LogStatus -> String -> Annex LogLine) -> Key -> UUID -> LogStatus -> Annex ()
|
|
logChange' mklog key (UUID u) s = do
|
|
config <- Annex.getGitConfig
|
|
maybeAddLog (locationLogFile config key) =<< mklog s u
|
|
logChange' _ _ NoUUID _ = noop
|
|
|
|
{- Returns a list of repository UUIDs that, according to the log, have
|
|
- the value of a key. -}
|
|
loggedLocations :: Key -> Annex [UUID]
|
|
loggedLocations = getLoggedLocations currentLogInfo
|
|
|
|
{- Gets the location log on a particular date. -}
|
|
loggedLocationsHistorical :: RefDate -> Key -> Annex [UUID]
|
|
loggedLocationsHistorical = getLoggedLocations . historicalLogInfo
|
|
|
|
{- Gets the locations contained in a git ref. -}
|
|
loggedLocationsRef :: Ref -> Annex [UUID]
|
|
loggedLocationsRef ref = map toUUID . getLog . L.unpack <$> catObject ref
|
|
|
|
getLoggedLocations :: (FilePath -> Annex [String]) -> Key -> Annex [UUID]
|
|
getLoggedLocations getter key = do
|
|
config <- Annex.getGitConfig
|
|
map toUUID <$> getter (locationLogFile config key)
|
|
|
|
{- Is there a location log for the key? True even for keys with no
|
|
- remaining locations. -}
|
|
isKnownKey :: Key -> Annex Bool
|
|
isKnownKey key = do
|
|
config <- Annex.getGitConfig
|
|
not . null <$> readLog (locationLogFile config key)
|
|
|
|
{- For a key to be dead, all locations that have location status for the key
|
|
- must have InfoDead set. -}
|
|
checkDead :: Key -> Annex Bool
|
|
checkDead key = do
|
|
config <- Annex.getGitConfig
|
|
ls <- compactLog <$> readLog (locationLogFile config key)
|
|
return $! all (\l -> status l == InfoDead) ls
|
|
|
|
{- Updates the log to say that a key is dead.
|
|
-
|
|
- Changes all logged lines for the key, in any location, that are
|
|
- currently InfoMissing, to be InfoDead.
|
|
-}
|
|
setDead :: Key -> Annex ()
|
|
setDead key = do
|
|
config <- Annex.getGitConfig
|
|
let logfile = locationLogFile config key
|
|
ls <- compactLog <$> readLog logfile
|
|
mapM_ (go logfile) (filter (\l -> status l == InfoMissing) ls)
|
|
where
|
|
go logfile l = addLog logfile $ setDead' l
|
|
|
|
{- Note that the timestamp in the log is updated minimally, so that this
|
|
- can be overruled by other location log changes. -}
|
|
setDead' :: LogLine -> LogLine
|
|
setDead' l = l
|
|
{ status = InfoDead
|
|
, date = date l + realToFrac (picosecondsToDiffTime 1)
|
|
}
|
|
|
|
{- Finds all keys that have location log information.
|
|
- (There may be duplicate keys in the list.)
|
|
-
|
|
- Keys that have been marked as dead are not included.
|
|
-}
|
|
loggedKeys :: Annex [Key]
|
|
loggedKeys = loggedKeys' (not <$$> checkDead)
|
|
|
|
{- Note that sel should be strict, to avoid the filterM building many
|
|
- thunks. -}
|
|
loggedKeys' :: (Key -> Annex Bool) -> Annex [Key]
|
|
loggedKeys' sel = filterM sel =<<
|
|
(mapMaybe locationLogFileKey <$> Annex.Branch.files)
|
|
|
|
{- Finds all keys that have location log information indicating
|
|
- they are present for the specified repository. -}
|
|
loggedKeysFor :: UUID -> Annex [Key]
|
|
loggedKeysFor u = loggedKeys' isthere
|
|
where
|
|
isthere k = do
|
|
us <- loggedLocations k
|
|
let !there = u `elem` us
|
|
return there
|