1 files changed, 160 insertions, 0 deletions
diff --git a/LocationLog.hs b/LocationLog.hs
new file mode 100644
index 000000000..785b3330d
--- /dev/null
+++ b/LocationLog.hs
@@ -0,0 +1,160 @@
+{- git-annex location log
+ -
+ - git-annex keeps track of on which repository it last saw a value.
+ - This can be useful when using it for archiving with offline storage.
+ - When you indicate you --want a file, git-annex will tell you which
+ - repositories have the value.
+ -
+ - Location tracking information is stored in `.git-annex/key.log`.
+ - Repositories record their UUID and the date when they --get or --drop
+ - a value.
+ -
+ - A line of the log will look like: "date N UUID"
+ - Where N=1 when the repo has the file, and 0 otherwise.
+ - 
+ - Git is configured to use a union merge for this file,
+ - so the lines may be in arbitrary order, but it will never conflict.
+ -}
+
+module LocationLog (
+	LogStatus(..),
+	logChange,
+	keyLocations
+) where
+
+import Data.Time.Clock.POSIX
+import Data.Time
+import System.Locale
+import qualified Data.Map as Map
+import System.IO
+import System.Directory
+import Data.Char
+
+import qualified GitRepo as Git
+import Utility
+import UUID
+import Types
+import Locations
+
+data LogLine = LogLine {
+	date :: POSIXTime,
+	status :: LogStatus,
+	uuid :: UUID
+} deriving (Eq)
+
+data LogStatus = ValuePresent | ValueMissing | Undefined
+	deriving (Eq)
+
+instance Show LogStatus where
+	show ValuePresent = "1"
+	show ValueMissing = "0"
+	show Undefined = "undefined"
+
+instance Read LogStatus where
+	readsPrec _ "1" = [(ValuePresent, "")]
+	readsPrec _ "0" = [(ValueMissing, "")]
+	readsPrec _ _   = [(Undefined, "")]
+
+instance Show LogLine where
+	show (LogLine date status uuid) = unwords
+		[(show date), (show status), uuid]
+
+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 case (pdate) of
+				Just v -> good v
+				Nothing -> undefined
+			else undefined
+		where
+			w = words string
+			date = w !! 0
+			status = read $ w !! 1
+			uuid = w !! 2
+			pdate = (parseTime defaultTimeLocale "%s%Qs" date) :: Maybe UTCTime
+
+			good v = ret $ LogLine (utcTimeToPOSIXSeconds v) status uuid
+			undefined = ret $ LogLine (0) Undefined ""
+			ret v = [(v, "")]
+
+{- Log a change in the presence of a key's value in a repository. -}
+logChange :: Git.Repo -> Key -> UUID -> LogStatus -> IO ()
+logChange repo key uuid status = do
+	log <- logNow status uuid
+	ls <- readLog logfile
+	writeLog logfile (compactLog $ log:ls)
+	where
+		logfile = logFile repo key
+
+{- Reads a log file.
+ - Note that the LogLines returned may be in any order. -}
+readLog :: FilePath -> IO [LogLine]
+readLog file = do
+	exists <- doesFileExist file
+	if exists
+		then do
+			s <- withFileLocked file ReadMode $ \h -> 
+				hGetContentsStrict h
+			-- filter out any unparsable lines
+			return $ filter (\l -> (status l) /= Undefined )
+				$ map read $ lines s
+		else do
+			return []
+
+{- Adds a LogLine to a log file -}
+appendLog :: FilePath -> LogLine -> IO ()
+appendLog file line = do
+	createDirectoryIfMissing True (parentDir file)
+	withFileLocked file AppendMode $ \h ->
+		hPutStrLn h $ show line
+
+{- Writes a set of lines to a log file -}
+writeLog :: FilePath -> [LogLine] -> IO ()
+writeLog file lines = do
+	createDirectoryIfMissing True (parentDir file)
+	withFileLocked file WriteMode $ \h ->
+		hPutStr h $ unlines $ map show lines
+
+{- Generates a new LogLine with the current date. -}
+logNow :: LogStatus -> UUID -> IO LogLine
+logNow status uuid = do
+	now <- getPOSIXTime
+	return $ LogLine now status uuid
+
+{- Returns the filename of the log file for a given key. -}
+logFile :: Git.Repo -> Key -> String
+logFile repo key = 
+	(gitStateDir repo) ++ (Git.relative repo (keyFile key)) ++ ".log"
+
+{- Returns a list of repository UUIDs that, according to the log, have
+ - the value of a key. -}
+keyLocations :: Git.Repo -> Key -> IO [UUID]
+keyLocations thisrepo key = do
+	lines <- readLog $ logFile thisrepo key
+	return $ map uuid (filterPresent lines)
+
+{- Filters the list of LogLines to find ones where the value
+ - is (or should still be) present. -}
+filterPresent :: [LogLine] -> [LogLine]
+filterPresent lines = filter (\l -> ValuePresent == status l) $ compactLog lines
+
+{- Compacts a set of logs, returning a subset that contains the current
+ - status. -}
+compactLog :: [LogLine] -> [LogLine]
+compactLog lines = compactLog' Map.empty lines
+compactLog' map [] = Map.elems map
+compactLog' map (l:ls) = compactLog' (mapLog map l) ls
+
+{- Inserts a log into a map of logs, if the log has better (ie, newer)
+ - information about a repo than the other logs in the map -}
+mapLog map log = 
+	if (better)
+		then Map.insert (uuid log) log map
+		else map
+	where
+		better = case (Map.lookup (uuid log) map) of
+			Just l -> (date l <= date log)
+			Nothing -> True