reorganize log modules

no code changes

6 files changed, 545 insertions, 0 deletions

diff --git a/Logs/Location.hs b/Logs/Location.hs
new file mode 100644
index 000000000..4e8b2b535
--- /dev/null
+++ b/Logs/Location.hs
@@ -0,0 +1,58 @@
+{- 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-2011 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Logs.Location (
+	LogStatus(..),
+	logChange,
+	readLog,
+	keyLocations,
+	loggedKeys,
+	logFile,
+	logFileKey
+) where
+
+import Common.Annex
+import qualified Git
+import qualified Annex.Branch
+import Logs.UUID
+import Logs.Presence
+
+{- Log a change in the presence of a key's value in a repository. -}
+logChange :: Git.Repo -> Key -> UUID -> LogStatus -> Annex ()
+logChange repo key u s
+	| null u = error $
+		"unknown UUID for " ++ Git.repoDescribe repo ++ 
+		" (have you run git annex init there?)"
+	| otherwise = addLog (logFile key) =<< logNow s u
+
+{- Returns a list of repository UUIDs that, according to the log, have
+ - the value of a key. -}
+keyLocations :: Key -> Annex [UUID]
+keyLocations = currentLog . logFile
+
+{- Finds all keys that have location log information.
+ - (There may be duplicate keys in the list.) -}
+loggedKeys :: Annex [Key]
+loggedKeys = mapMaybe (logFileKey . takeFileName) <$> Annex.Branch.files
+
+{- The filename of the log file for a given key. -}
+logFile :: Key -> String
+logFile key = hashDirLower key ++ keyFile key ++ ".log"
+
+{- Converts a log filename into a key. -}
+logFileKey :: FilePath -> Maybe Key
+logFileKey file
+	| end == ".log" = fileKey beginning
+	| otherwise = Nothing
+	where
+		(beginning, end) = splitAt (length file - 4) file
diff --git a/Logs/Presence.hs b/Logs/Presence.hs
new file mode 100644
index 000000000..7211eba03
--- /dev/null
+++ b/Logs/Presence.hs
@@ -0,0 +1,124 @@
+{- git-annex presence log
+ -
+ - This is used to store presence information in the git-annex branch in
+ - 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.
+ - 
+ - Copyright 2010-2011 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Logs.Presence (
+	LogStatus(..),
+	addLog,
+	readLog,
+	parseLog,
+	logNow,
+	compactLog,
+	currentLog,
+	LogLine
+) where
+
+import Data.Time.Clock.POSIX
+import Data.Time
+import System.Locale
+import qualified Data.Map as M
+
+import Common.Annex
+import qualified Annex.Branch
+
+data LogLine = LogLine {
+	date :: POSIXTime,
+	status :: LogStatus,
+	info :: String
+} deriving (Eq)
+
+data LogStatus = InfoPresent | InfoMissing | Undefined
+	deriving (Eq)
+
+instance Show LogStatus where
+	show InfoPresent = "1"
+	show InfoMissing = "0"
+	show Undefined = "undefined"
+
+instance Read LogStatus where
+	readsPrec _ "1" = [(InfoPresent, "")]
+	readsPrec _ "0" = [(InfoMissing, "")]
+	readsPrec _ _   = [(Undefined, "")]
+
+instance Show LogLine where
+	show (LogLine d s i) = unwords [show d, show s, i]
+
+instance Read LogLine where
+	-- This parser is robust in that even unparsable log lines are
+	-- read without an exception being thrown.
+	-- Such lines have a status of Undefined.
+	readsPrec _ string = 
+		if length w >= 3
+			then maybe bad good pdate
+			else bad
+		where
+			w = words string
+			s = read $ w !! 1
+			i = w !! 2
+			pdate :: Maybe UTCTime
+			pdate = parseTime defaultTimeLocale "%s%Qs" $ head w
+
+			good v = ret $ LogLine (utcTimeToPOSIXSeconds v) s i
+			bad = ret $ LogLine 0 Undefined ""
+			ret v = [(v, "")]
+
+addLog :: FilePath -> LogLine -> Annex ()
+addLog file line = Annex.Branch.change file $ \s -> 
+	showLog $ compactLog (line : parseLog s)
+
+{- Reads a log file.
+ - Note that the LogLines returned may be in any order. -}
+readLog :: FilePath -> Annex [LogLine]
+readLog file = parseLog <$> Annex.Branch.get file
+
+parseLog :: String -> [LogLine]
+parseLog = filter parsable . map read . lines
+	where
+		-- some lines may be unparseable, avoid them
+		parsable l = status l /= Undefined
+
+{- Generates a log file. -}
+showLog :: [LogLine] -> String
+showLog = unlines . map show
+
+{- Generates a new LogLine with the current date. -}
+logNow :: LogStatus -> String -> Annex LogLine
+logNow s i = do
+	now <- liftIO getPOSIXTime
+	return $ LogLine now s i
+
+{- Reads a log and returns only the info that is still in effect. -}
+currentLog :: FilePath -> Annex [String]
+currentLog file = map info . filterPresent <$> readLog file
+
+{- Returns the info from LogLines that are in effect. -}
+filterPresent :: [LogLine] -> [LogLine]
+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
+
+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 = 
+	if better
+		then M.insert i l m
+		else m
+	where
+		better = maybe True newer $ M.lookup i m
+		newer l' = date l' <= date l
+		i = info l
diff --git a/Logs/Remote.hs b/Logs/Remote.hs
new file mode 100644
index 000000000..47c2d7472
--- /dev/null
+++ b/Logs/Remote.hs
@@ -0,0 +1,88 @@
+{- git-annex remote log
+ - 
+ - Copyright 2011 Joey Hess <joey@kitenet.net>
+ - 
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Logs.Remote (
+	readRemoteLog,
+	configSet,
+	keyValToConfig,
+	configToKeyVal,
+
+	prop_idempotent_configEscape
+) where
+
+import qualified Data.Map as M
+import Data.Time.Clock.POSIX
+import Data.Char
+
+import Common.Annex
+import qualified Annex.Branch
+import Types.Remote
+import Logs.UUID
+import Logs.UUIDBased
+
+{- Filename of remote.log. -}
+remoteLog :: FilePath
+remoteLog = "remote.log"
+
+{- Adds or updates a remote's config in the log. -}
+configSet :: UUID -> RemoteConfig -> Annex ()
+configSet u c = do
+	ts <- liftIO $ getPOSIXTime
+	Annex.Branch.change remoteLog $
+		showLog showConfig . changeLog ts u c . parseLog parseConfig
+
+{- Map of remotes by uuid containing key/value config maps. -}
+readRemoteLog :: Annex (M.Map UUID RemoteConfig)
+readRemoteLog = (simpleMap . parseLog parseConfig) <$> Annex.Branch.get remoteLog
+
+parseConfig :: String -> Maybe RemoteConfig
+parseConfig = Just . keyValToConfig . words
+
+showConfig :: RemoteConfig -> String
+showConfig = unwords . configToKeyVal
+
+{- Given Strings like "key=value", generates a RemoteConfig. -}
+keyValToConfig :: [String] -> RemoteConfig
+keyValToConfig ws = M.fromList $ map (/=/) ws
+	where
+		(/=/) s = (k, v)
+			where
+				k = takeWhile (/= '=') s
+				v = configUnEscape $ drop (1 + length k) s
+
+configToKeyVal :: M.Map String String -> [String]
+configToKeyVal m = map toword $ sort $ M.toList m
+	where
+		toword (k, v) = k ++ "=" ++ configEscape v
+
+configEscape :: String -> String
+configEscape = (>>= escape)
+	where
+		escape c
+			| isSpace c || c `elem` "&" = "&" ++ show (ord c) ++ ";"
+			| otherwise = [c]
+
+configUnEscape :: String -> String
+configUnEscape = unescape
+	where
+		unescape [] = []
+		unescape (c:rest)
+			| c == '&' = entity rest
+			| otherwise = c : unescape rest
+		entity s = if ok
+				then chr (read num) : unescape rest
+				else '&' : unescape s
+			where
+				num = takeWhile isNumber s
+				r = drop (length num) s
+				rest = drop 1 r
+				ok = not (null num) && 
+					not (null r) && head r == ';'
+
+{- for quickcheck -}
+prop_idempotent_configEscape :: String -> Bool
+prop_idempotent_configEscape s = s == (configUnEscape . configEscape) s
diff --git a/Logs/Trust.hs b/Logs/Trust.hs
new file mode 100644
index 000000000..6966ffdd6
--- /dev/null
+++ b/Logs/Trust.hs
@@ -0,0 +1,70 @@
+{- git-annex trust
+ -
+ - Copyright 2010 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Logs.Trust (
+	TrustLevel(..),
+	trustGet,
+	trustSet,
+	trustPartition
+) where
+
+import qualified Data.Map as M
+import Data.Time.Clock.POSIX
+
+import Common.Annex
+import Types.TrustLevel
+import qualified Annex.Branch
+import qualified Annex
+
+import Logs.UUID
+import Logs.UUIDBased
+
+{- Filename of trust.log. -}
+trustLog :: FilePath
+trustLog = "trust.log"
+
+{- Returns a list of UUIDs at the specified trust level. -}
+trustGet :: TrustLevel -> Annex [UUID]
+trustGet level = M.keys . M.filter (== level) <$> trustMap
+
+{- Read the trustLog into a map, overriding with any
+ - values from forcetrust. The map is cached for speed. -}
+trustMap :: Annex TrustMap
+trustMap = do
+	cached <- Annex.getState Annex.trustmap
+	case cached of
+		Just m -> return m
+		Nothing -> do
+			overrides <- M.fromList <$> Annex.getState Annex.forcetrust
+			m <- (M.union overrides . simpleMap . parseLog parseTrust) <$>
+				Annex.Branch.get trustLog
+			Annex.changeState $ \s -> s { Annex.trustmap = Just m }
+			return m
+
+parseTrust :: String -> Maybe TrustLevel
+parseTrust s
+	| length w > 0 = readMaybe $ head w
+	-- back-compat; the trust.log used to only list trusted repos
+	| otherwise = Just Trusted
+	where
+		w = words s
+
+{- Changes the trust level for a uuid in the trustLog. -}
+trustSet :: UUID -> TrustLevel -> Annex ()
+trustSet uuid level = do
+	when (null uuid) $
+		error "unknown UUID; cannot modify trust level"
+	ts <- liftIO $ getPOSIXTime
+	Annex.Branch.change trustLog $
+		showLog show . changeLog ts uuid level . parseLog parseTrust
+	Annex.changeState $ \s -> s { Annex.trustmap = Nothing }
+
+{- Partitions a list of UUIDs to those matching a TrustLevel and not. -}
+trustPartition :: TrustLevel -> [UUID] -> Annex ([UUID], [UUID])
+trustPartition level ls = do
+	candidates <- trustGet level
+	return $ partition (`elem` candidates) ls
diff --git a/Logs/UUID.hs b/Logs/UUID.hs
new file mode 100644
index 000000000..baf665001
--- /dev/null
+++ b/Logs/UUID.hs
@@ -0,0 +1,95 @@
+{- git-annex uuids
+ -
+ - Each git repository used by git-annex has an annex.uuid setting that
+ - uniquely identifies that repository.
+ -
+ - UUIDs of remotes are cached in git config, using keys named
+ - remote.<name>.annex-uuid
+ -
+ - uuid.log stores a list of known uuids, and their descriptions.
+ -
+ - Copyright 2010-2011 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Logs.UUID (
+	UUID,
+	getUUID,
+	getRepoUUID,
+	getUncachedUUID,
+	prepUUID,
+	genUUID,
+	describeUUID,
+	uuidMap
+) where
+
+import qualified Data.Map as M
+import Data.Time.Clock.POSIX
+
+import Common.Annex
+import qualified Git
+import qualified Annex.Branch
+import Types.UUID
+import qualified Build.SysConfig as SysConfig
+import Config
+import Logs.UUIDBased
+
+configkey :: String
+configkey = "annex.uuid"
+
+{- Filename of uuid.log. -}
+logfile :: FilePath
+logfile = "uuid.log"
+
+{- Generates a UUID. There is a library for this, but it's not packaged,
+ - so use the command line tool. -}
+genUUID :: IO UUID
+genUUID = pOpen ReadFromPipe command params hGetLine
+	where
+		command = SysConfig.uuid
+		params = if command == "uuid"
+			-- request a random uuid be generated
+			then ["-m"]
+			-- uuidgen generates random uuid by default
+			else []
+
+getUUID :: Annex UUID
+getUUID = getRepoUUID =<< gitRepo
+
+{- Looks up a repo's UUID. May return "" if none is known. -}
+getRepoUUID :: Git.Repo -> Annex UUID
+getRepoUUID r = do
+	g <- gitRepo
+
+	let c = cached g
+	let u = getUncachedUUID r
+	
+	if c /= u && u /= ""
+		then do
+			updatecache g u
+			return u
+		else return c
+	where
+		cached g = Git.configGet g cachekey ""
+		updatecache g u = when (g /= r) $ setConfig cachekey u
+		cachekey = "remote." ++ fromMaybe "" (Git.repoRemoteName r) ++ ".annex-uuid"
+
+getUncachedUUID :: Git.Repo -> UUID
+getUncachedUUID r = Git.configGet r configkey ""
+
+{- Make sure that the repo has an annex.uuid setting. -}
+prepUUID :: Annex ()
+prepUUID = whenM (null <$> getUUID) $
+	setConfig configkey =<< liftIO genUUID
+
+{- Records a description for a uuid in the log. -}
+describeUUID :: UUID -> String -> Annex ()
+describeUUID uuid desc = do
+	ts <- liftIO $ getPOSIXTime
+	Annex.Branch.change logfile $
+		showLog id . changeLog ts uuid desc . parseLog Just
+
+{- Read the uuidLog into a simple Map -}
+uuidMap :: Annex (M.Map UUID String)
+uuidMap = (simpleMap . parseLog Just) <$> Annex.Branch.get logfile
diff --git a/Logs/UUIDBased.hs b/Logs/UUIDBased.hs
new file mode 100644
index 000000000..46fa80be0
--- /dev/null
+++ b/Logs/UUIDBased.hs
@@ -0,0 +1,110 @@
+{- git-annex uuid-based logs
+ -
+ - This is used to store information about a UUID in a way that can
+ - be union merged.
+ -
+ - A line of the log will look like: "UUID[ INFO[ timestamp=foo]]"
+ - The timestamp is last for backwards compatability reasons,
+ - and may not be present on old log lines.
+ - 
+ - Copyright 2011 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Logs.UUIDBased (
+	Log,
+	LogEntry(..),
+	parseLog,
+	showLog,
+	changeLog,
+	addLog,
+	simpleMap,
+
+	prop_TimeStamp_sane,
+	prop_addLog_sane,
+) where
+
+import qualified Data.Map as M
+import Data.Time.Clock.POSIX
+import Data.Time
+import System.Locale
+
+import Common
+import Types.UUID
+
+data TimeStamp = Unknown | Date POSIXTime
+	deriving (Eq, Ord, Show)
+
+data LogEntry a = LogEntry
+	{ changed :: TimeStamp
+	, value :: a
+	} deriving (Eq, Show)
+
+type Log a = M.Map UUID (LogEntry a)
+
+tskey :: String
+tskey = "timestamp="
+
+showLog :: (a -> String) -> Log a -> String
+showLog shower = unlines . map showpair . M.toList
+	where
+		showpair (k, LogEntry (Date p) v) =
+			unwords [k, shower v, tskey ++ show p]
+		showpair (k, LogEntry Unknown v) =
+			unwords [k, shower v]
+
+parseLog :: (String -> Maybe a) -> String -> Log a
+parseLog parser = M.fromListWith best . catMaybes . map pair . lines
+	where
+		pair line
+			| null ws = Nothing
+			| otherwise = case parser $ unwords info of
+				Nothing -> Nothing
+				Just v -> Just (u, LogEntry c v)
+			where
+				ws = words line
+				u = head ws
+				end = last ws
+				c
+					| tskey `isPrefixOf` end =
+						pdate $ tail $ dropWhile (/= '=') end
+					| otherwise = Unknown
+				info
+					| c == Unknown = drop 1 ws
+					| otherwise = drop 1 $ init ws
+				pdate s = case parseTime defaultTimeLocale "%s%Qs" s of
+					Nothing -> Unknown
+					Just d -> Date $ utcTimeToPOSIXSeconds d
+
+changeLog :: POSIXTime -> UUID -> a -> Log a -> Log a
+changeLog t u v = M.insert u $ LogEntry (Date t) v
+
+{- Only add an LogEntry if it's newer (or at least as new as) than any
+ - existing LogEntry for a UUID. -}
+addLog :: UUID -> LogEntry a -> Log a -> Log a
+addLog = M.insertWith best
+
+{- Converts a Log into a simple Map without the timestamp information.
+ - This is a one-way trip, but useful for code that never needs to change
+ - the log. -}
+simpleMap :: Log a -> M.Map UUID a
+simpleMap = M.map value
+
+best :: LogEntry a -> LogEntry a -> LogEntry a
+best new old
+	| changed old > changed new = old
+	| otherwise = new
+
+-- Unknown is oldest.
+prop_TimeStamp_sane :: Bool
+prop_TimeStamp_sane = Unknown < Date 1
+
+prop_addLog_sane :: Bool
+prop_addLog_sane = newWins && newestWins
+	where
+		newWins = addLog "foo" (LogEntry (Date 1) "new") l == l2
+		newestWins = addLog "foo" (LogEntry (Date 1) "newest") l2 /= l2
+
+		l = M.fromList [("foo", LogEntry (Date 0) "old")]
+		l2 = M.fromList [("foo", LogEntry (Date 1) "new")]