diff options
Diffstat (limited to 'Logs')
| -rw-r--r-- | Logs/Location.hs | 2 | ||||
| -rw-r--r-- | Logs/Presence.hs | 16 | ||||
| -rw-r--r-- | Logs/Presence/Pure.hs | 36 |
3 files changed, 42 insertions, 12 deletions
diff --git a/Logs/Location.hs b/Logs/Location.hs index ba9c31abf..89100805b 100644 --- a/Logs/Location.hs +++ b/Logs/Location.hs @@ -48,7 +48,7 @@ logChange = logChange' logNow logChange' :: (LogStatus -> String -> Annex LogLine) -> Key -> UUID -> LogStatus -> Annex () logChange' mklog key (UUID u) s = do config <- Annex.getGitConfig - addLog (locationLogFile config key) =<< mklog s u + maybeAddLog (locationLogFile config key) =<< mklog s u logChange' _ _ NoUUID _ = noop {- Returns a list of repository UUIDs that, according to the log, have diff --git a/Logs/Presence.hs b/Logs/Presence.hs index 60e0c542a..f90253421 100644 --- a/Logs/Presence.hs +++ b/Logs/Presence.hs @@ -4,7 +4,7 @@ - a way that can be union merged. - - A line of the log will look like: "date N INFO" - - Where N=1 when the INFO is present, and 0 otherwise. + - Where N=1 when the INFO is present, 0 otherwise. - - Copyright 2010-2014 Joey Hess <id@joeyh.name> - @@ -14,6 +14,7 @@ module Logs.Presence ( module X, addLog, + maybeAddLog, readLog, logNow, currentLog, @@ -28,10 +29,21 @@ import Common.Annex import qualified Annex.Branch import Git.Types (RefDate) +{- Adds a LogLine to the log, removing any LogLines that are obsoleted by + - adding it. -} addLog :: FilePath -> LogLine -> Annex () -addLog file line = Annex.Branch.change file $ \s -> +addLog file line = Annex.Branch.change file $ \s -> showLog $ compactLog (line : parseLog s) +{- When a LogLine already exists with the same status and info, but an + - older timestamp, that LogLine is preserved, rather than updating the log + - with a newer timestamp. + -} +maybeAddLog :: FilePath -> LogLine -> Annex () +maybeAddLog file line = Annex.Branch.maybeChange file $ \s -> do + m <- insertNewStatus line $ logMap $ parseLog s + return $ showLog $ mapLog m + {- Reads a log file. - Note that the LogLines returned may be in any order. -} readLog :: FilePath -> Annex [LogLine] diff --git a/Logs/Presence/Pure.hs b/Logs/Presence/Pure.hs index b1fc212fd..4e5ff68c0 100644 --- a/Logs/Presence/Pure.hs +++ b/Logs/Presence/Pure.hs @@ -61,21 +61,39 @@ filterPresent = filter (\l -> InfoPresent == status l) . compactLog {- Compacts a set of logs, returning a subset that contains the current - status. -} compactLog :: [LogLine] -> [LogLine] -compactLog = M.elems . foldr mapLog M.empty +compactLog = mapLog . logMap type LogMap = M.Map String LogLine -{- Inserts a log into a map of logs, if the log has better (ie, newer) - - information than the other logs in the map -} -mapLog :: LogLine -> LogMap -> LogMap -mapLog l m - | better = M.insert i l m - | otherwise = m +mapLog :: LogMap -> [LogLine] +mapLog = M.elems + +logMap :: [LogLine] -> LogMap +logMap = foldr insertNewerLogLine M.empty + +insertBetter :: (LogLine -> Bool) -> LogLine -> LogMap -> Maybe LogMap +insertBetter betterthan l m + | better = Just (M.insert i l m) + | otherwise = Nothing where - better = maybe True newer $ M.lookup i m - newer l' = date l' <= date l + better = maybe True betterthan (M.lookup i m) i = info l +{- Inserts a log into a map of logs, if the log has newer + - information than the other logs in the map for the same info. -} +insertNewerLogLine :: LogLine -> LogMap -> LogMap +insertNewerLogLine l m = fromMaybe m $ insertBetter newer l m + where + newer l' = date l' <= date l + +{- Inserts the log unless there's already one in the map with + - the same status for its info, in which case there's no need to + - change anything, to avoid log churn. -} +insertNewStatus :: LogLine -> LogMap -> Maybe LogMap +insertNewStatus l m = insertBetter diffstatus l m + where + diffstatus l' = status l' /= status l + instance Arbitrary LogLine where arbitrary = LogLine <$> arbitrary |