2cecc8d2a3
Can be used to override the default timestamps used in log files in the git-annex branch. This is a dangerous environment variable; use with caution. Note that this only affects writing to the logs on the git-annex branch. It is not used for metadata in git commits (other env vars can be set for that). There are many other places where timestamps are still used, that don't get committed to git, but do touch disk. Including regular timestamps of files, and timestamps embedded in some files in .git/annex/, including the last fsck timestamp and timestamps in transfer log files. A good way to find such things in git-annex is to get for getPOSIXTime and getCurrentTime, although some of the results are of course false positives that never hit disk (unless git-annex gets swapped out..) So this commit does NOT necessarily make git-annex comply with some HIPPA privacy regulations; it's up to the user to determine if they can use it in a way compliant with such regulations. Benchmarking: It takes 0.00114 milliseconds to call getEnv "GIT_ANNEX_VECTOR_CLOCK" when that env var is not set. So, 100 thousand log files can be written with an added overhead of only 0.114 seconds. That should be by far swamped by the actual overhead of writing the log files and making the commit containing them. This commit was supported by the NSF-funded DataLad project.
139 lines
4 KiB
Haskell
139 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 Annex.VectorClock
|
|
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 = case date l of
|
|
VectorClock c -> VectorClock $
|
|
c + realToFrac (picosecondsToDiffTime 1)
|
|
Unknown -> Unknown
|
|
}
|
|
|
|
{- 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
|