code:
{- user-specified limits on files to act on
 -
 - Copyright 2011-2014 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Limit where

import Common.Annex
import qualified Annex
import qualified Utility.Matcher
import qualified Remote
import qualified Backend
import Annex.Content
import Annex.UUID
import Logs.Trust
import Config.NumCopies
import Types.TrustLevel
import Types.Key
import Types.Group
import Types.FileMatcher
import Types.MetaData
import Logs.MetaData
import Logs.Group
import Logs.Unused
import Logs.Location
import Git.Types (RefDate(..))
import Utility.Glob
import Utility.HumanTime
import Utility.DataUnits

import Data.Time.Clock.POSIX
import qualified Data.Set as S
import qualified Data.Map as M

{- Checks if there are user-specified limits. -}
limited :: Annex Bool
limited = (not . Utility.Matcher.isEmpty) <$> getMatcher'

{- Gets a matcher for the user-specified limits. The matcher is cached for
 - speed; once it's obtained the user-specified limits can't change. -}
getMatcher :: Annex (MatchInfo -> Annex Bool)
getMatcher = Utility.Matcher.matchM <$> getMatcher'

getMatcher' :: Annex (Utility.Matcher.Matcher (MatchInfo -> Annex Bool))
getMatcher' = go =<< Annex.getState Annex.limit
  where
	go (CompleteMatcher matcher) = return matcher
	go (BuildingMatcher l) = do
		let matcher = Utility.Matcher.generate (reverse l)
		Annex.changeState $ \s ->
			s { Annex.limit = CompleteMatcher matcher }
		return matcher

{- Adds something to the limit list, which is built up reversed. -}
add :: Utility.Matcher.Token (MatchInfo -> Annex Bool) -> Annex ()
add l = Annex.changeState $ \s -> s { Annex.limit = prepend $ Annex.limit s }
  where
	prepend (BuildingMatcher ls) = BuildingMatcher $ l:ls
	prepend _ = error "internal"

{- Adds a new token. -}
addToken :: String -> Annex ()
addToken = add . Utility.Matcher.token

{- Adds a new limit. -}
addLimit :: Either String (MatchFiles Annex) -> Annex ()
addLimit = either error (\l -> add $ Utility.Matcher.Operation $ l S.empty)

{- Add a limit to skip files that do not match the glob. -}
addInclude :: String -> Annex ()
addInclude = addLimit . limitInclude

limitInclude :: MkLimit Annex
limitInclude glob = Right $ const $ return . matchGlobFile glob

{- Add a limit to skip files that match the glob. -}
addExclude :: String -> Annex ()
addExclude = addLimit . limitExclude

limitExclude :: MkLimit Annex
limitExclude glob = Right $ const $ return . not . matchGlobFile glob

matchGlobFile :: String -> (MatchInfo -> Bool)
matchGlobFile glob = go
	where
		cglob = compileGlob glob CaseSensative -- memoized
		go (MatchingKey _) = False
		go (MatchingFile fi) = matchGlob cglob (matchFile fi)

{- Adds a limit to skip files not believed to be present
 - in a specfied repository. Optionally on a prior date. -}
addIn :: String -> Annex ()
addIn s = addLimit =<< mk
  where
	(name, date) = separate (== '@') s
	mk
		| name == "." = if null date
			then use inhere
			else use . inuuid =<< getUUID
		| otherwise = use . inuuid =<< Remote.nameToUUID name
	use a = return $ Right $ \notpresent -> checkKey (a notpresent)
	inuuid u notpresent key
		| null date = do
			us <- Remote.keyLocations key
			return $ u `elem` us && u `S.notMember` notpresent
		| otherwise = do
			us <- loggedLocationsHistorical (RefDate date) key
			return $ u `elem` us
	inhere notpresent key
		| S.null notpresent = inAnnex key
		| otherwise = do
			u <- getUUID
			if u `S.member` notpresent
				then return False
				else inAnnex key

{- Limit to content that is currently present on a uuid. -}
limitPresent :: Maybe UUID -> MkLimit Annex
limitPresent u _ = Right $ matchPresent u

matchPresent :: Maybe UUID -> MatchFiles Annex
matchPresent u _ = checkKey $ \key -> do
	hereu <- getUUID
	if u == Just hereu || isNothing u
		then inAnnex key
		else do
			us <- Remote.keyLocations key
			return $ maybe False (`elem` us) u

{- Limit to content that is in a directory, anywhere in the repository tree -}
limitInDir :: FilePath -> MkLimit Annex
limitInDir dir = const $ Right $ const go
  where
	go (MatchingFile fi) = return $ elem dir $ splitPath $ takeDirectory $ matchFile fi
	go (MatchingKey _) = return False

{- Adds a limit to skip files not believed to have the specified number
 - of copies. -}
addCopies :: String -> Annex ()
addCopies = addLimit . limitCopies

limitCopies :: MkLimit Annex
limitCopies want = case split ":" want of
	[v, n] -> case parsetrustspec v of
		Just checker -> go n $ checktrust checker
		Nothing -> go n $ checkgroup v
	[n] -> go n $ const $ return True
	_ -> Left "bad value for copies"
  where
	go num good = case readish num of
		Nothing -> Left "bad number for copies"
		Just n -> Right $ \notpresent -> checkKey $
			handle n good notpresent
	handle n good notpresent key = do
		us <- filter (`S.notMember` notpresent)
			<$> (filterM good =<< Remote.keyLocations key)
		return $ length us >= n
	checktrust checker u = checker <$> lookupTrust u
	checkgroup g u = S.member g <$> lookupGroups u
	parsetrustspec s
		| "+" `isSuffixOf` s = (>=) <$> readTrustLevel (beginning s)
		| otherwise = (==) <$> readTrustLevel s

{- Adds a limit to match files that need more copies made. -}
addLackingCopies :: Bool -> String -> Annex ()
addLackingCopies approx = addLimit . limitLackingCopies approx

limitLackingCopies :: Bool -> MkLimit Annex
limitLackingCopies approx want = case readish want of
	Just needed -> Right $ \notpresent mi -> flip checkKey mi $
		handle mi needed notpresent
	Nothing -> Left "bad value for number of lacking copies"
  where
	handle mi needed notpresent key = do
		NumCopies numcopies <- if approx
			then approxNumCopies
			else case mi of
				MatchingKey _ -> approxNumCopies
				MatchingFile fi -> getGlobalFileNumCopies $ matchFile fi
		us <- filter (`S.notMember` notpresent)
			<$> (trustExclude UnTrusted =<< Remote.keyLocations key)
		return $ numcopies - length us >= needed
	approxNumCopies = fromMaybe defaultNumCopies <$> getGlobalNumCopies

{- Match keys that are unused.
 -
 - This has a nice optimisation: When a file exists,
 - its key is obviously not unused.
 -}
limitUnused :: MatchFiles Annex
limitUnused _ (MatchingFile _) = return False
limitUnused _ (MatchingKey k) = S.member k <$> unusedKeys

{- Adds a limit to skip files not believed to be present in all
 - repositories in the specified group. -}
addInAllGroup :: String -> Annex ()
addInAllGroup groupname = do
	m <- groupMap
	addLimit $ limitInAllGroup m groupname

limitInAllGroup :: GroupMap -> MkLimit Annex
limitInAllGroup m groupname
	| S.null want = Right $ const $ const $ return True
	| otherwise = Right $ \notpresent -> checkKey $ check notpresent
  where
	want = fromMaybe S.empty $ M.lookup groupname $ uuidsByGroup m
	check notpresent key
		-- optimisation: Check if a wanted uuid is notpresent.
		| not (S.null (S.intersection want notpresent))	= return False
		| otherwise = do
			present <- S.fromList <$> Remote.keyLocations key
			return $ S.null $ want `S.difference` present

{- Adds a limit to skip files not using a specified key-value backend. -}
addInBackend :: String -> Annex ()
addInBackend = addLimit . limitInBackend

limitInBackend :: MkLimit Annex
limitInBackend name = Right $ const $ checkKey check
  where
	check key = pure $ keyBackendName key == name

{- Adds a limit to skip files that are too large or too small -}
addLargerThan :: String -> Annex ()
addLargerThan = addLimit . limitSize (>)

addSmallerThan :: String -> Annex ()
addSmallerThan = addLimit . limitSize (<)

limitSize :: (Maybe Integer -> Maybe Integer -> Bool) -> MkLimit Annex
limitSize vs s = case readSize dataUnits s of
	Nothing -> Left "bad size"
	Just sz -> Right $ go sz
  where
  	go sz _ (MatchingFile fi) = lookupFileKey fi >>= check fi sz
	go sz _ (MatchingKey key) = checkkey sz key
	checkkey sz key = return $ keySize key `vs` Just sz
	check _ sz (Just key) = checkkey sz key
	check fi sz Nothing = do
		filesize <- liftIO $ catchMaybeIO $
			fromIntegral . fileSize
				<$> getFileStatus (relFile fi)
		return $ filesize `vs` Just sz

addMetaData :: String -> Annex ()
addMetaData = addLimit . limitMetaData

limitMetaData :: MkLimit Annex
limitMetaData s = case parseMetaData s of
	Left e -> Left e
	Right (f, v) ->
		let cglob = compileGlob (fromMetaValue v) CaseInsensative
		in Right $ const $ checkKey (check f cglob)
  where
  	check f cglob k = not . S.null
		. S.filter (matchGlob cglob . fromMetaValue)
		. metaDataValues f <$> getCurrentMetaData k

addTimeLimit :: String -> Annex ()
addTimeLimit s = do
	let seconds = maybe (error "bad time-limit") durationToPOSIXTime $
		parseDuration s
	start <- liftIO getPOSIXTime
	let cutoff = start + seconds
	addLimit $ Right $ const $ const $ do
		now <- liftIO getPOSIXTime
		if now > cutoff
			then do
				warning $ "Time limit (" ++ s ++ ") reached!"
				liftIO $ exitWith $ ExitFailure 101
			else return True

lookupFileKey :: FileInfo -> Annex (Maybe Key)
lookupFileKey = Backend.lookupFile . relFile

checkKey :: (Key -> Annex Bool) -> MatchInfo -> Annex Bool
checkKey a (MatchingFile fi) = lookupFileKey fi >>= maybe (return False) a
checkKey a (MatchingKey k) = a k


code:
{- git-annex limits by wanted status
 -
 - Copyright 2012 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Limit.Wanted where

import Common.Annex
import Annex.Wanted
import Limit
import Types.FileMatcher

addWantGet :: Annex ()
addWantGet = addLimit $ Right $ const $ checkWant $ wantGet False Nothing

addWantDrop :: Annex ()
addWantDrop = addLimit $ Right $ const $ checkWant $ wantDrop False Nothing Nothing

checkWant :: (Maybe FilePath -> Annex Bool) -> MatchInfo -> Annex Bool
checkWant a (MatchingFile fi) = a (Just $ matchFile fi)
checkWant _ (MatchingKey _) = return False

repo_name: kakafarm/git

license: unknown


code:
{- git-annex file locations
 -
 - Copyright 2010-2013 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Locations (
	keyFile,
	fileKey,
	keyPaths,
	keyPath,
	annexDir,
	objectDir,
	gitAnnexLocation,
	gitAnnexLink,
	gitAnnexContentLock,
	gitAnnexMapping,
	gitAnnexInodeCache,
	gitAnnexInodeSentinal,
	gitAnnexInodeSentinalCache,
	annexLocations,
	annexLocation,
	gitAnnexDir,
	gitAnnexObjectDir,
	gitAnnexTmpMiscDir,
	gitAnnexTmpObjectDir,
	gitAnnexTmpObjectLocation,
	gitAnnexBadDir,
	gitAnnexBadLocation,
	gitAnnexUnusedLog,
	gitAnnexFsckState,
	gitAnnexFsckResultsLog,
	gitAnnexScheduleState,
	gitAnnexTransferDir,
	gitAnnexCredsDir,
	gitAnnexWebCertificate,
	gitAnnexWebPrivKey,
	gitAnnexFeedStateDir,
	gitAnnexFeedState,
	gitAnnexMergeDir,
	gitAnnexJournalDir,
	gitAnnexJournalLock,
	gitAnnexPreCommitLock,
	gitAnnexMergeLock,
	gitAnnexIndex,
	gitAnnexIndexStatus,
	gitAnnexViewIndex,
	gitAnnexViewLog,
	gitAnnexIgnoredRefs,
	gitAnnexPidFile,
	gitAnnexDaemonStatusFile,
	gitAnnexLogFile,
	gitAnnexFuzzTestLogFile,
	gitAnnexHtmlShim,
	gitAnnexUrlFile,
	gitAnnexTmpCfgFile,
	gitAnnexSshDir,
	gitAnnexRemotesDir,
	gitAnnexAssistantDefaultDir,
	isLinkToAnnex,
	annexHashes,
	hashDirMixed,
	hashDirLower,
	preSanitizeKeyName,

	prop_idempotent_fileKey
) where

import Data.Bits
import Data.Word
import Data.Hash.MD5
import Data.Char

import Common
import Types
import Types.Key
import Types.UUID
import qualified Git

{- Conventions:
 -
 - Functions ending in "Dir" should always return values ending with a
 - trailing path separator. Most code does not rely on that, but a few
 - things do.
 -
 - Everything else should not end in a trailing path sepatator.
 -
 - Only functions (with names starting with "git") that build a path
 - based on a git repository should return an absolute path.
 - Everything else should use relative paths.
 -}

{- The directory git annex uses for local state, relative to the .git
 - directory -}
annexDir :: FilePath
annexDir = addTrailingPathSeparator "annex"

{- The directory git annex uses for locally available object content,
 - relative to the .git directory -}
objectDir :: FilePath
objectDir = addTrailingPathSeparator $ annexDir </> "objects"

{- Annexed file's possible locations relative to the .git directory.
 - There are two different possibilities, using different hashes. -}
annexLocations :: Key -> [FilePath]
annexLocations key = map (annexLocation key) annexHashes
annexLocation :: Key -> Hasher -> FilePath
annexLocation key hasher = objectDir </> keyPath key hasher

{- Annexed object's absolute location in a repository.
 -
 - When there are multiple possible locations, returns the one where the
 - file is actually present.
 -
 - When the file is not present, returns the location where the file should
 - be stored.
 -
 - This does not take direct mode into account, so in direct mode it is not
 - the actual location of the file's content.
 -}
gitAnnexLocation :: Key -> Git.Repo -> GitConfig -> IO FilePath
gitAnnexLocation key r config = gitAnnexLocation' key r (annexCrippledFileSystem config)
gitAnnexLocation' :: Key -> Git.Repo -> Bool -> IO FilePath
gitAnnexLocation' key r crippled
	{- Bare repositories default to hashDirLower for new
	 - content, as it's more portable.
	 -
	 - Repositories on filesystems that are crippled also use
	 - hashDirLower, since they do not use symlinks and it's
	 - more portable. -}
	| Git.repoIsLocalBare r || crippled =
		check $ map inrepo $ annexLocations key
	{- Non-bare repositories only use hashDirMixed, so
	 - don't need to do any work to check if the file is
	 - present. -}
	| otherwise = return $ inrepo $ annexLocation key hashDirMixed
  where
	inrepo d = Git.localGitDir r </> d
	check locs@(l:_) = fromMaybe l <$> firstM doesFileExist locs
	check [] = error "internal"

{- Calculates a symlink to link a file to an annexed object. -}
gitAnnexLink :: FilePath -> Key -> Git.Repo -> IO FilePath
gitAnnexLink file key r = do
	currdir <- getCurrentDirectory
	let absfile = fromMaybe whoops $ absNormPathUnix currdir file
	loc <- gitAnnexLocation' key r False
	return $ relPathDirToFile (parentDir absfile) loc
  where
  	whoops = error $ "unable to normalize " ++ file

{- File used to lock a key's content. -}
gitAnnexContentLock :: Key -> Git.Repo -> GitConfig -> IO FilePath
gitAnnexContentLock key r config = do
	loc <- gitAnnexLocation key r config
	return $ loc ++ ".lck"

{- File that maps from a key to the file(s) in the git repository.
 - Used in direct mode. -}
gitAnnexMapping :: Key -> Git.Repo -> GitConfig -> IO FilePath
gitAnnexMapping key r config = do
	loc <- gitAnnexLocation key r config
	return $ loc ++ ".map"

{- File that caches information about a key's content, used to determine
 - if a file has changed.
 - Used in direct mode. -}
gitAnnexInodeCache :: Key -> Git.Repo -> GitConfig -> IO FilePath
gitAnnexInodeCache key r config  = do
	loc <- gitAnnexLocation key r config
	return $ loc ++ ".cache"

gitAnnexInodeSentinal :: Git.Repo -> FilePath
gitAnnexInodeSentinal r = gitAnnexDir r </> "sentinal"

gitAnnexInodeSentinalCache :: Git.Repo -> FilePath
gitAnnexInodeSentinalCache r = gitAnnexInodeSentinal r ++ ".cache"

{- The annex directory of a repository. -}
gitAnnexDir :: Git.Repo -> FilePath
gitAnnexDir r = addTrailingPathSeparator $ Git.localGitDir r </> annexDir

{- The part of the annex directory where file contents are stored. -}
gitAnnexObjectDir :: Git.Repo -> FilePath
gitAnnexObjectDir r = addTrailingPathSeparator $ Git.localGitDir r </> objectDir

{- .git/annex/misctmp/ is used for random temp files -}
gitAnnexTmpMiscDir :: Git.Repo -> FilePath
gitAnnexTmpMiscDir r = addTrailingPathSeparator $ gitAnnexDir r </> "misctmp"

{- .git/annex/tmp/ is used for temp files for key's contents -}
gitAnnexTmpObjectDir :: Git.Repo -> FilePath
gitAnnexTmpObjectDir r = addTrailingPathSeparator $ gitAnnexDir r </> "tmp"

{- The temp file to use for a given key's content. -}
gitAnnexTmpObjectLocation :: Key -> Git.Repo -> FilePath
gitAnnexTmpObjectLocation key r = gitAnnexTmpObjectDir r </> keyFile key

{- .git/annex/bad/ is used for bad files found during fsck -}
gitAnnexBadDir :: Git.Repo -> FilePath
gitAnnexBadDir r = addTrailingPathSeparator $ gitAnnexDir r </> "bad"

{- The bad file to use for a given key. -}
gitAnnexBadLocation :: Key -> Git.Repo -> FilePath
gitAnnexBadLocation key r = gitAnnexBadDir r </> keyFile key

{- .git/annex/foounused is used to number possibly unused keys -}
gitAnnexUnusedLog :: FilePath -> Git.Repo -> FilePath
gitAnnexUnusedLog prefix r = gitAnnexDir r </> (prefix ++ "unused")

{- .git/annex/fsckstate is used to store information about incremental fscks. -}
gitAnnexFsckState :: Git.Repo -> FilePath
gitAnnexFsckState r = gitAnnexDir r </> "fsckstate"

{- .git/annex/fsckresults/uuid is used to store results of git fscks -}
gitAnnexFsckResultsLog :: UUID -> Git.Repo -> FilePath
gitAnnexFsckResultsLog u r = gitAnnexDir r </> "fsckresults" </> fromUUID u

{- .git/annex/schedulestate is used to store information about when
 - scheduled jobs were last run. -}
gitAnnexScheduleState :: Git.Repo -> FilePath
gitAnnexScheduleState r = gitAnnexDir r </> "schedulestate"

{- .git/annex/creds/ is used to store credentials to access some special
 - remotes. -}
gitAnnexCredsDir :: Git.Repo -> FilePath
gitAnnexCredsDir r = addTrailingPathSeparator $ gitAnnexDir r </> "creds"

{- .git/annex/certificate.pem and .git/annex/key.pem are used by the webapp
 - when HTTPS is enabled -}
gitAnnexWebCertificate :: Git.Repo -> FilePath
gitAnnexWebCertificate r = gitAnnexDir r </> "certificate.pem"
gitAnnexWebPrivKey :: Git.Repo -> FilePath
gitAnnexWebPrivKey r = gitAnnexDir r </> "privkey.pem"

{- .git/annex/feeds/ is used to record per-key (url) state by importfeeds -}
gitAnnexFeedStateDir :: Git.Repo -> FilePath
gitAnnexFeedStateDir r = addTrailingPathSeparator $ gitAnnexDir r </> "feedstate"

gitAnnexFeedState :: Key -> Git.Repo -> FilePath
gitAnnexFeedState k r = gitAnnexFeedStateDir r </> keyFile k

{- .git/annex/merge/ is used for direct mode merges. -}
gitAnnexMergeDir :: Git.Repo -> FilePath
gitAnnexMergeDir r = addTrailingPathSeparator $ gitAnnexDir r </> "merge"

{- .git/annex/transfer/ is used to record keys currently
 - being transferred, and other transfer bookkeeping info. -}
gitAnnexTransferDir :: Git.Repo -> FilePath
gitAnnexTransferDir r = addTrailingPathSeparator $ gitAnnexDir r </> "transfer"

{- .git/annex/journal/ is used to journal changes made to the git-annex
 - branch -}
gitAnnexJournalDir :: Git.Repo -> FilePath
gitAnnexJournalDir r = addTrailingPathSeparator $ gitAnnexDir r </> "journal"

{- Lock file for the journal. -}
gitAnnexJournalLock :: Git.Repo -> FilePath
gitAnnexJournalLock r = gitAnnexDir r </> "journal.lck"

{- Lock file for the pre-commit hook. -}
gitAnnexPreCommitLock :: Git.Repo -> FilePath
gitAnnexPreCommitLock r = gitAnnexDir r </> "precommit.lck"

{- Lock file for direct mode merge. -}
gitAnnexMergeLock :: Git.Repo -> FilePath
gitAnnexMergeLock r = gitAnnexDir r </> "merge.lck"

{- .git/annex/index is used to stage changes to the git-annex branch -}
gitAnnexIndex :: Git.Repo -> FilePath
gitAnnexIndex r = gitAnnexDir r </> "index"

{- Holds the ref of the git-annex branch that the index was last updated to.
 -
 - The .lck in the name is a historical accident; this is not used as a
 - lock. -}
gitAnnexIndexStatus :: Git.Repo -> FilePath
gitAnnexIndexStatus r = gitAnnexDir r </> "index.lck"

{- The index file used to generate a filtered branch view._-}
gitAnnexViewIndex :: Git.Repo -> FilePath
gitAnnexViewIndex r = gitAnnexDir r </> "viewindex"

{- File containing a log of recently accessed views. -}
gitAnnexViewLog :: Git.Repo -> FilePath
gitAnnexViewLog r = gitAnnexDir r </> "viewlog"

{- List of refs that should not be merged into the git-annex branch. -}
gitAnnexIgnoredRefs :: Git.Repo -> FilePath
gitAnnexIgnoredRefs r = gitAnnexDir r </> "ignoredrefs"

{- Pid file for daemon mode. -}
gitAnnexPidFile :: Git.Repo -> FilePath
gitAnnexPidFile r = gitAnnexDir r </> "daemon.pid"

{- Status file for daemon mode. -}
gitAnnexDaemonStatusFile :: Git.Repo -> FilePath
gitAnnexDaemonStatusFile r = gitAnnexDir r </> "daemon.status"

{- Log file for daemon mode. -}
gitAnnexLogFile :: Git.Repo -> FilePath
gitAnnexLogFile r = gitAnnexDir r </> "daemon.log"

{- Log file for fuzz test. -}
gitAnnexFuzzTestLogFile :: Git.Repo -> FilePath
gitAnnexFuzzTestLogFile r = gitAnnexDir r </> "fuzztest.log"

{- Html shim file used to launch the webapp. -}
gitAnnexHtmlShim :: Git.Repo -> FilePath
gitAnnexHtmlShim r = gitAnnexDir r </> "webapp.html"

{- File containing the url to the webapp. -}
gitAnnexUrlFile :: Git.Repo -> FilePath
gitAnnexUrlFile r = gitAnnexDir r </> "url"

{- Temporary file used to edit configuriation from the git-annex branch. -}
gitAnnexTmpCfgFile :: Git.Repo -> FilePath
gitAnnexTmpCfgFile r = gitAnnexDir r </> "config.tmp"

{- .git/annex/ssh/ is used for ssh connection caching -}
gitAnnexSshDir :: Git.Repo -> FilePath
gitAnnexSshDir r = addTrailingPathSeparator $ gitAnnexDir r </> "ssh"

{- .git/annex/remotes/ is used for remote-specific state. -}
gitAnnexRemotesDir :: Git.Repo -> FilePath
gitAnnexRemotesDir r = addTrailingPathSeparator $ gitAnnexDir r </> "remotes"

{- This is the base directory name used by the assistant when making
 - repositories, by default. -}
gitAnnexAssistantDefaultDir :: FilePath
gitAnnexAssistantDefaultDir = "annex"

{- Checks a symlink target to see if it appears to point to annexed content.
 -
 - We only look at paths inside the .git directory, and not at the .git
 - directory itself, because GIT_DIR may cause a directory name other
 - than .git to be used.
 -}
isLinkToAnnex :: FilePath -> Bool
isLinkToAnnex s = (pathSeparator:objectDir) `isInfixOf` s

{- Sanitizes a String that will be used as part of a Key's keyName,
 - dealing with characters that cause problems on substandard filesystems.
 -
 - This is used when a new Key is initially being generated, eg by getKey.
 - Unlike keyFile and fileKey, it does not need to be a reversable
 - escaping. Also, it's ok to change this to add more problimatic
 - characters later. Unlike changing keyFile, which could result in the
 - filenames used for existing keys changing and contents getting lost.
 -
 - It is, however, important that the input and output of this function
 - have a 1:1 mapping, to avoid two different inputs from mapping to the
 - same key.
 -}
preSanitizeKeyName :: String -> String
preSanitizeKeyName = concatMap escape
  where
  	escape c
		| isAsciiUpper c || isAsciiLower c || isDigit c = [c]
		| c `elem` ".-_ " = [c] -- common, assumed safe
		| c `elem` "/%:" = [c] -- handled by keyFile
		-- , is safe and uncommon, so will be used to escape
		-- other characters. By itself, it is escaped to
		-- doubled form.
		| c == ',' = ",,"
		| otherwise = ',' : show (ord c)

{- Converts a key into a filename fragment without any directory.
 -
 - Escape "/" in the key name, to keep a flat tree of files and avoid
 - issues with keys containing "/../" or ending with "/" etc.
 -
 - "/" is escaped to "%" because it's short and rarely used, and resembles
 -     a slash
 - "%" is escaped to "&s", and "&" to "&a"; this ensures that the mapping
 -     is one to one.
 - ":" is escaped to "&c", because it seemed like a good idea at the time.
 -
 - Changing what this function escapes and how is not a good idea, as it
 - can cause existing objects to get lost.
 -}
keyFile :: Key -> FilePath
keyFile key = replace "/" "%" $ replace ":" "&c" $
	replace "%" "&s" $ replace "&" "&a"  $ key2file key

{- Reverses keyFile, converting a filename fragment (ie, the basename of
 - the symlink target) into a key. -}
fileKey :: FilePath -> Maybe Key
fileKey file = file2key $
	replace "&a" "&" $ replace "&s" "%" $
		replace "&c" ":" $ replace "%" "/" file

{- for quickcheck -}
prop_idempotent_fileKey :: String -> Bool
prop_idempotent_fileKey s
	| null s = True -- it's not legal for a key to have no keyName
	| otherwise= Just k == fileKey (keyFile k)
  where
	k = stubKey { keyName = s, keyBackendName = "test" }

{- A location to store a key on the filesystem. A directory hash is used,
 - to protect against filesystems that dislike having many items in a
 - single directory.
 -
 - The file is put in a directory with the same name, this allows
 - write-protecting the directory to avoid accidental deletion of the file.
 -}
keyPath :: Key -> Hasher -> FilePath
keyPath key hasher = hasher key </> f </> f
  where
	f = keyFile key

{- All possibile locations to store a key using different directory hashes. -}
keyPaths :: Key -> [FilePath]
keyPaths key = map (keyPath key) annexHashes

{- Two different directory hashes may be used. The mixed case hash
 - came first, and is fine, except for the problem of case-strict
 - filesystems such as Linux VFAT (mounted with shortname=mixed),
 - which do not allow using a directory "XX" when "xx" already exists.
 - To support that, most repositories use the lower case hash for new data. -}
type Hasher = Key -> FilePath

annexHashes :: [Hasher]
annexHashes = [hashDirLower, hashDirMixed]

hashDirMixed :: Hasher
hashDirMixed k = addTrailingPathSeparator $ take 2 dir </> drop 2 dir
  where
	dir = take 4 $ display_32bits_as_dir =<< [a,b,c,d]
	ABCD (a,b,c,d) = md5 $ md5FilePath $ key2file $ nonChunkKey k

hashDirLower :: Hasher
hashDirLower k = addTrailingPathSeparator $ take 3 dir </> drop 3 dir
  where
	dir = take 6 $ md5s $ md5FilePath $ key2file $ nonChunkKey k

{- modified version of display_32bits_as_hex from Data.Hash.MD5
 -   Copyright (C) 2001 Ian Lynagh
 -   License: Either BSD or GPL
 -}
display_32bits_as_dir :: Word32 -> String
display_32bits_as_dir w = trim $ swap_pairs cs
  where
	-- Need 32 characters to use. To avoid inaverdently making
	-- a real word, use letters that appear less frequently.
	chars = ['0'..'9'] ++ "zqjxkmvwgpfZQJXKMVWGPF"
	cs = map (\x -> getc $ (shiftR w (6*x)) .&. 31) [0..7]
	getc n = chars !! fromIntegral n
	swap_pairs (x1:x2:xs) = x2:x1:swap_pairs xs
	swap_pairs _ = []
	-- Last 2 will always be 00, so omit.
	trim = take 6


code:
{- git-annex log file names
 -
 - Copyright 2013-2014 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Logs where

import Common.Annex
import Types.Key

{- There are several varieties of log file formats. -}
data LogVariety
	= UUIDBasedLog
	| NewUUIDBasedLog
	| ChunkLog Key
	| PresenceLog Key
	| OtherLog
	deriving (Show)

{- Converts a path from the git-annex branch into one of the varieties
 - of logs used by git-annex, if it's a known path. -}
getLogVariety :: FilePath -> Maybe LogVariety
getLogVariety f
	| f `elem` topLevelUUIDBasedLogs = Just UUIDBasedLog
	| isRemoteStateLog f = Just NewUUIDBasedLog
	| isChunkLog f = ChunkLog <$> chunkLogFileKey f
	| isMetaDataLog f || f `elem` otherLogs = Just OtherLog
	| otherwise = PresenceLog <$> firstJust (presenceLogs f)

{- All the uuid-based logs stored in the top of the git-annex branch. -}
topLevelUUIDBasedLogs :: [FilePath]
topLevelUUIDBasedLogs =
	[ uuidLog
	, remoteLog
	, trustLog
	, groupLog
	, preferredContentLog
	, requiredContentLog
	, scheduleLog
	]

{- All the ways to get a key from a presence log file -}
presenceLogs :: FilePath -> [Maybe Key]
presenceLogs f =
	[ urlLogFileKey f
	, locationLogFileKey f
	]

{- Logs that are neither UUID based nor presence logs. -}
otherLogs :: [FilePath]
otherLogs =
	[ numcopiesLog
	, groupPreferredContentLog
	]

uuidLog :: FilePath
uuidLog = "uuid.log"

numcopiesLog :: FilePath
numcopiesLog = "numcopies.log"

remoteLog :: FilePath
remoteLog = "remote.log"

trustLog :: FilePath
trustLog = "trust.log"

groupLog :: FilePath
groupLog = "group.log"

preferredContentLog :: FilePath
preferredContentLog = "preferred-content.log"

requiredContentLog :: FilePath
requiredContentLog = "required-content.log"

groupPreferredContentLog :: FilePath
groupPreferredContentLog = "group-preferred-content.log"

scheduleLog :: FilePath
scheduleLog = "schedule.log"

{- The pathname of the location log file for a given key. -}
locationLogFile :: Key -> String
locationLogFile key = hashDirLower key ++ keyFile key ++ ".log"

{- Converts a pathname into a key if it's a location log. -}
locationLogFileKey :: FilePath -> Maybe Key
locationLogFileKey path
	| ["remote", "web"] `isPrefixOf` splitDirectories dir = Nothing
        | ext == ".log" = fileKey base
        | otherwise = Nothing
  where
	(dir, file) = splitFileName path
        (base, ext) = splitAt (length file - 4) file

{- The filename of the url log for a given key. -}
urlLogFile :: Key -> FilePath
urlLogFile key = hashDirLower key </> keyFile key ++ urlLogExt

{- Old versions stored the urls elsewhere. -}
oldurlLogs :: Key -> [FilePath]
oldurlLogs key =
	[ "remote/web" </> hashDirLower key </> key2file key ++ ".log"
	, "remote/web" </> hashDirLower key </> keyFile key ++ ".log"
	]

urlLogExt :: String
urlLogExt = ".log.web"

{- Converts a url log file into a key.
 - (Does not work on oldurlLogs.) -}
urlLogFileKey :: FilePath -> Maybe Key
urlLogFileKey path
	| ext == urlLogExt = fileKey base
	| otherwise = Nothing
  where
  	file = takeFileName path
	(base, ext) = splitAt (length file - extlen) file
	extlen = length urlLogExt

{- Does not work on oldurllogs. -}
isUrlLog :: FilePath -> Bool
isUrlLog file = urlLogExt `isSuffixOf` file

{- The filename of the remote state log for a given key. -}
remoteStateLogFile :: Key -> FilePath
remoteStateLogFile key = hashDirLower key </> keyFile key ++ remoteStateLogExt

remoteStateLogExt :: String
remoteStateLogExt = ".log.rmt"

isRemoteStateLog :: FilePath -> Bool
isRemoteStateLog path = remoteStateLogExt `isSuffixOf` path

{- The filename of the chunk log for a given key. -}
chunkLogFile :: Key -> FilePath
chunkLogFile key = hashDirLower key </> keyFile key ++ chunkLogExt

chunkLogFileKey :: FilePath -> Maybe Key
chunkLogFileKey path
	| ext == chunkLogExt = fileKey base
	| otherwise = Nothing
  where
  	file = takeFileName path
	(base, ext) = splitAt (length file - extlen) file
	extlen = length chunkLogExt

chunkLogExt :: String
chunkLogExt = ".log.cnk"

isChunkLog :: FilePath -> Bool
isChunkLog path = chunkLogExt `isSuffixOf` path

{- The filename of the metadata log for a given key. -}
metaDataLogFile :: Key -> FilePath
metaDataLogFile key = hashDirLower key </> keyFile key ++ metaDataLogExt

metaDataLogExt :: String
metaDataLogExt = ".log.met"

isMetaDataLog :: FilePath -> Bool
isMetaDataLog path = metaDataLogExt `isSuffixOf` path

prop_logs_sane :: Key -> Bool
prop_logs_sane dummykey = and
	[ isNothing (getLogVariety "unknown")
	, expect gotUUIDBasedLog (getLogVariety uuidLog)
	, expect gotPresenceLog (getLogVariety $ locationLogFile dummykey)
	, expect gotPresenceLog (getLogVariety $ urlLogFile dummykey)
	, expect gotNewUUIDBasedLog (getLogVariety $ remoteStateLogFile dummykey)
	, expect gotChunkLog (getLogVariety $ chunkLogFile dummykey)
	, expect gotOtherLog (getLogVariety $ metaDataLogFile dummykey)
	, expect gotOtherLog (getLogVariety $ numcopiesLog)
	]
  where
  	expect = maybe False
	gotUUIDBasedLog UUIDBasedLog = True
	gotUUIDBasedLog _ = False
  	gotNewUUIDBasedLog NewUUIDBasedLog = True
	gotNewUUIDBasedLog _ = False
	gotChunkLog (ChunkLog k) = k == dummykey
	gotChunkLog _ = False
	gotPresenceLog (PresenceLog k) = k == dummykey
	gotPresenceLog _ = False
	gotOtherLog OtherLog = True
	gotOtherLog _ = False


code:
{- Chunk logs.
 -
 - An object can be stored in chunked for on a remote; these logs keep
 - track of the chunk size used, and the number of chunks.
 -
 - It's possible for a single object to be stored multiple times on the
 - same remote using different chunk sizes. So, while this is a MapLog, it
 - is not a normal UUIDBased log. Intead, it's a map from UUID and chunk
 - size to number of chunks.
 -
 - Format: "timestamp uuid:chunksize chunkcount"
 -
 - Copyright 2014 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Logs.Chunk (
	ChunkMethod(..),
	ChunkSize,
	ChunkCount,
	chunksStored,
	chunksRemoved,
	getCurrentChunks,
) where

import Common.Annex
import Logs
import Logs.MapLog
import qualified Annex.Branch
import Logs.Chunk.Pure

import qualified Data.Map as M
import Data.Time.Clock.POSIX

chunksStored :: UUID -> Key -> ChunkMethod -> ChunkCount -> Annex ()
chunksStored u k chunkmethod chunkcount = do
	ts <- liftIO getPOSIXTime
	Annex.Branch.change (chunkLogFile k) $
		showLog . changeMapLog ts (u, chunkmethod) chunkcount . parseLog

chunksRemoved :: UUID -> Key -> ChunkMethod -> Annex ()
chunksRemoved u k chunkmethod = chunksStored u k chunkmethod 0

getCurrentChunks :: UUID -> Key -> Annex [(ChunkMethod, ChunkCount)]
getCurrentChunks u k = select . parseLog <$> Annex.Branch.get (chunkLogFile k)
  where
	select = filter (\(_m, ct) -> ct > 0)
		. map (\((_ku, m), l) -> (m, value l))
		. M.toList
		. M.filterWithKey (\(ku, _m) _ -> ku == u)


code:
{- Chunk logs, pure operations.
 -
 - Copyright 2014 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Logs.Chunk.Pure
	( ChunkMethod(..)
	, ChunkSize
	, ChunkCount
	, ChunkLog
	, parseLog
	, showLog
	) where

import Common.Annex
import Logs.MapLog
import Data.Int

-- Currently chunks are all fixed size, but other chunking methods
-- may be added.
data ChunkMethod = FixedSizeChunks ChunkSize | UnknownChunks String
	deriving (Ord, Eq, Show)

type ChunkSize = Int64

-- 0 when chunks are no longer present
type ChunkCount = Integer

type ChunkLog = MapLog (UUID, ChunkMethod) ChunkCount

parseChunkMethod :: String -> ChunkMethod
parseChunkMethod s = maybe (UnknownChunks s) FixedSizeChunks (readish s)

showChunkMethod :: ChunkMethod -> String
showChunkMethod (FixedSizeChunks sz) = show sz
showChunkMethod (UnknownChunks s) = s

parseLog :: String -> ChunkLog
parseLog = parseMapLog fieldparser valueparser
  where
	fieldparser s =
		let (u,m) = separate (== sep) s
		in Just (toUUID u, parseChunkMethod m)
	valueparser = readish

showLog :: ChunkLog -> String
showLog = showMapLog fieldshower valueshower
  where
	fieldshower (u, m) = fromUUID u ++ sep : showChunkMethod m
	valueshower = show

sep :: Char
sep = ':'


code:
{- git-annex fsck results log files
 -
 - Copyright 2013 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Logs.FsckResults (
	writeFsckResults,
	readFsckResults,
	clearFsckResults,
) where

import Common.Annex
import Utility.Tmp
import Git.Fsck
import Git.Types

import qualified Data.Set as S

writeFsckResults :: UUID -> FsckResults -> Annex ()
writeFsckResults u fsckresults = do
	logfile <- fromRepo $ gitAnnexFsckResultsLog u
	liftIO $
		case fsckresults of
			FsckFailed -> store S.empty False logfile
			FsckFoundMissing s t
				| S.null s -> nukeFile logfile
				| otherwise -> store s t logfile
  where
  	store s t logfile = do
		createDirectoryIfMissing True (parentDir logfile)
		liftIO $ viaTmp writeFile logfile $ serialize s t
	serialize s t =
		let ls = map fromRef (S.toList s)
		in if t
			then unlines ("truncated":ls)
			else unlines ls

readFsckResults :: UUID -> Annex FsckResults
readFsckResults u = do
	logfile <- fromRepo $ gitAnnexFsckResultsLog u
	liftIO $ catchDefaultIO (FsckFoundMissing S.empty False) $
		deserialize . lines <$> readFile logfile
  where
	deserialize ("truncated":ls) = deserialize' ls True
	deserialize ls = deserialize' ls False
	deserialize' ls t =
		let s = S.fromList $ map Ref ls
		in if S.null s then FsckFailed else FsckFoundMissing s t

clearFsckResults :: UUID -> Annex ()
clearFsckResults = liftIO . nukeFile <=< fromRepo . gitAnnexFsckResultsLog


code:
{- git-annex group log
 -
 - Copyright 2012 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Logs.Group (
	groupLog,
	groupChange,
	groupSet,
	lookupGroups,
	groupMap,
	groupMapLoad,
	getStandardGroup,
	inUnwantedGroup
) where

import qualified Data.Map as M
import qualified Data.Set as S
import Data.Time.Clock.POSIX

import Common.Annex
import Logs
import qualified Annex.Branch
import qualified Annex
import Logs.UUIDBased
import Types.Group
import Types.StandardGroups

{- Returns the groups of a given repo UUID. -}
lookupGroups :: UUID -> Annex (S.Set Group)
lookupGroups u = (fromMaybe S.empty . M.lookup u) . groupsByUUID <$> groupMap

{- Applies a set modifier to change the groups for a uuid in the groupLog. -}
groupChange :: UUID -> (S.Set Group -> S.Set Group) -> Annex ()
groupChange uuid@(UUID _) modifier = do
	curr <- lookupGroups uuid
	ts <- liftIO getPOSIXTime
	Annex.Branch.change groupLog $
		showLog (unwords . S.toList) .
			changeLog ts uuid (modifier curr) .
				parseLog (Just . S.fromList . words)

	-- The changed group invalidates the preferred content cache.
	Annex.changeState $ \s -> s
		{ Annex.groupmap = Nothing
		, Annex.preferredcontentmap = Nothing
		}
groupChange NoUUID _ = error "unknown UUID; cannot modify"

groupSet :: UUID -> S.Set Group -> Annex ()
groupSet u g = groupChange u (const g)

{- The map is cached for speed. -}
groupMap :: Annex GroupMap
groupMap = maybe groupMapLoad return =<< Annex.getState Annex.groupmap

{- Loads the map, updating the cache. -}
groupMapLoad :: Annex GroupMap
groupMapLoad = do
	m <- makeGroupMap . simpleMap .
		parseLog (Just . S.fromList . words) <$>
			Annex.Branch.get groupLog
	Annex.changeState $ \s -> s { Annex.groupmap = Just m }
	return m

makeGroupMap :: M.Map UUID (S.Set Group) -> GroupMap
makeGroupMap byuuid = GroupMap byuuid bygroup
  where
	bygroup = M.fromListWith S.union $
		concatMap explode $ M.toList byuuid
	explode (u, s) = map (\g -> (g, S.singleton u)) (S.toList s)

{- If a repository is in exactly one standard group, returns it. -}
getStandardGroup :: S.Set Group -> Maybe StandardGroup
getStandardGroup s = case mapMaybe toStandardGroup $ S.toList s of
	[g] -> Just g
	_ -> Nothing

inUnwantedGroup :: UUID -> Annex Bool
inUnwantedGroup u = elem UnwantedGroup
	. mapMaybe toStandardGroup . S.toList <$> lookupGroups u


code:
{-# 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-2014 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Logs.Location (
	LogStatus(..),
	logStatus,
	logChange,
	loggedLocations,
	loggedLocationsHistorical,
	loggedKeys,
	loggedKeysFor,
) where

import Common.Annex
import qualified Annex.Branch
import Logs
import Logs.Presence
import Annex.UUID
import Git.Types (RefDate)

{- 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 key (UUID u) s = addLog (locationLogFile key) =<< logNow 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 currentLog

{- Gets the location log on a particular date. -}
loggedLocationsHistorical :: RefDate -> Key -> Annex [UUID]
loggedLocationsHistorical = getLoggedLocations . historicalLog

getLoggedLocations :: (FilePath -> Annex [String]) -> Key -> Annex [UUID]
getLoggedLocations getter key = map toUUID <$> (getter . locationLogFile) key

{- Finds all keys that have location log information.
 - (There may be duplicate keys in the list.) -}
loggedKeys :: Annex [Key]
loggedKeys = 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 = filterM isthere =<< loggedKeys
  where
	{- This should run strictly to avoid the filterM
	 - building many thunks containing keyLocations data. -}
	isthere k = do
		us <- loggedLocations k
		let !there = u `elem` us
		return there


code:
{- git-annex Map log
 -
 - This is used to store a Map, in a way that can be union merged.
 -
 - A line of the log will look like: "timestamp field value"
 -
 - Copyright 2014 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Logs.MapLog where

import qualified Data.Map as M
import Data.Time.Clock.POSIX
import Data.Time
import System.Locale

import Common

data TimeStamp = Unknown | Date POSIXTime
	deriving (Eq, Ord, Show)

data LogEntry v = LogEntry
	{ changed :: TimeStamp
	, value :: v
	} deriving (Eq, Show)

type MapLog f v = M.Map f (LogEntry v)

showMapLog :: (f -> String) -> (v -> String) -> MapLog f v -> String
showMapLog fieldshower valueshower = unlines . map showpair . M.toList
  where
	showpair (f, LogEntry (Date p) v) =
		unwords [show p, fieldshower f, valueshower v]
	showpair (f, LogEntry Unknown v) =
		unwords ["0", fieldshower f, valueshower v]

parseMapLog :: Ord f => (String -> Maybe f) -> (String -> Maybe v) -> String -> MapLog f v
parseMapLog fieldparser valueparser = M.fromListWith best . mapMaybe parse . lines
  where
	parse line = do
		let (ts, rest) = splitword line
		    (sf, sv) = splitword rest
		date <- Date . utcTimeToPOSIXSeconds <$> parseTime defaultTimeLocale "%s%Qs" ts
		f <- fieldparser sf
		v <- valueparser sv
		Just (f, LogEntry date v)
	splitword = separate (== ' ')

changeMapLog :: Ord f => POSIXTime -> f -> v -> MapLog f v -> MapLog f v
changeMapLog t f v = M.insert f $ LogEntry (Date t) v

{- Only add an LogEntry if it's newer (or at least as new as) than any
 - existing LogEntry for a field. -}
addMapLog :: Ord f => f -> LogEntry v -> MapLog f v -> MapLog f v
addMapLog = M.insertWith' best

{- Converts a MapLog 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 :: MapLog f v -> M.Map f v
simpleMap = M.map value

best :: LogEntry v -> LogEntry v -> LogEntry v
best new old
	| changed old > changed new = old
	| otherwise = new

-- Unknown is oldest.
prop_TimeStamp_sane :: Bool
prop_TimeStamp_sane = Unknown < Date 1

prop_addMapLog_sane :: Bool
prop_addMapLog_sane = newWins && newestWins
  where
	newWins = addMapLog ("foo") (LogEntry (Date 1) "new") l == l2
	newestWins = addMapLog ("foo") (LogEntry (Date 1) "newest") l2 /= l2

	l = M.fromList [("foo", LogEntry (Date 0) "old")]
	l2 = M.fromList [("foo", LogEntry (Date 1) "new")]


code:
{- git-annex general metadata storage log
 -
 - A line of the log will look like "timestamp field [+-]value [...]"
 -
 - Note that unset values are preserved. Consider this case:
 -
 - We have:
 -
 - 100 foo +x
 - 200 foo -x
 -
 - An unmerged remote has:
 -
 - 150 foo +x
 -
 - After union merge, because the foo -x was preserved, we know that
 - after the other remote redundantly set foo +x, it was unset,
 - and so foo currently has no value.
 -
 -
 - Copyright 2014 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE CPP #-}

module Logs.MetaData (
	getCurrentMetaData,
	addMetaData,
	addMetaData',
	currentMetaData,
	copyMetaData,
) where

import Common.Annex
import Types.MetaData
import Annex.MetaData.StandardFields
import qualified Annex.Branch
import Logs
import Logs.SingleValue

import qualified Data.Set as S
import qualified Data.Map as M
import Data.Time.Clock.POSIX
import Data.Time.Format
import System.Locale

instance SingleValueSerializable MetaData where
	serialize = Types.MetaData.serialize
	deserialize = Types.MetaData.deserialize

getMetaDataLog :: Key -> Annex (Log MetaData)
getMetaDataLog = readLog . metaDataLogFile

{- Go through the log from oldest to newest, and combine it all
 - into a single MetaData representing the current state.
 -
 - Automatically generates a lastchanged metadata for each field that's
 - currently set, based on timestamps in the log.
 -}
getCurrentMetaData :: Key -> Annex MetaData
getCurrentMetaData k = do
	ls <- S.toAscList <$> getMetaDataLog k
	let loggedmeta = currentMetaData $ combineMetaData $ map value ls
	return $ currentMetaData $ unionMetaData loggedmeta
		(lastchanged ls loggedmeta)
  where
  	lastchanged [] _ = emptyMetaData
	lastchanged ls (MetaData currentlyset) =
		let m = foldl' (flip M.union) M.empty (map genlastchanged ls)
		in MetaData $
			-- Add a overall lastchanged using the oldest log
			-- item (log is in ascending order).
			M.insert lastChangedField (lastchangedval $ Prelude.last ls) $
			M.mapKeys mkLastChangedField $
			-- Only include fields that are currently set.
			m `M.intersection` currentlyset
	-- Makes each field have the timestamp as its value.
	genlastchanged l =
		let MetaData m = value l
		    ts = lastchangedval l
		in M.map (const ts) m
	lastchangedval l = S.singleton $ toMetaValue $ showts $ changed l
	showts = formatTime defaultTimeLocale "%F@%H-%M-%S" . posixSecondsToUTCTime

{- Adds in some metadata, which can override existing values, or unset
 - them, but otherwise leaves any existing metadata as-is. -}
addMetaData :: Key -> MetaData -> Annex ()
addMetaData k metadata = addMetaData' k metadata =<< liftIO getPOSIXTime

{- Reusing the same timestamp when making changes to the metadata
 - of multiple keys is a nice optimisation. The same metadata lines
 - will tend to be generated across the different log files, and so
 - git will be able to pack the data more efficiently. -}
addMetaData' :: Key -> MetaData -> POSIXTime -> Annex ()
addMetaData' k d@(MetaData m) now
	| d == emptyMetaData = noop
	| otherwise = Annex.Branch.change (metaDataLogFile k) $
		showLog . simplifyLog
			. S.insert (LogEntry now metadata)
			. parseLog
  where
	metadata = MetaData $ M.filterWithKey (\f _ -> not (isLastChangedField f)) m

{- Simplify a log, removing historical values that are no longer
 - needed.
 -
 - This is not as simple as just making a single log line with the newest
 - state of all metadata. Consider this case:
 -
 - We have:
 -
 - 100 foo +x bar +y
 - 200 foo -x
 -
 - An unmerged remote has:
 -
 - 150 bar -y baz +w
 -
 - If what we have were simplified to "200 foo -x bar +y" then when the line
 - from the remote became available, it would be older than the simplified
 - line, and its change to bar would not take effect. That is wrong.
 -
 - Instead, simplify it to:
 -
 - 100 bar +y
 - 200 foo -x
 -
 - (Note that this ends up with the same number of lines as the
 - unsimplified version, so there's really no point in updating
 - the log to this version. Doing so would only add data to git,
 - with little benefit.)
 -
 - Now merging with the remote yields:
 -
 - 100 bar +y
 - 150 bar -y baz +w
 - 200 foo -x
 -
 - Simplifying again:
 -
 - 150 bar +z baz +w
 - 200 foo -x
 -}
simplifyLog :: Log MetaData -> Log MetaData
simplifyLog s = case sl of
	(newest:rest) ->
		let sl' = go [newest] (value newest) rest
		in if length sl' < length sl
			then S.fromList sl'
			else s
	_ -> s
  where
#if MIN_VERSION_containers(0,5,0)
	sl = S.toDescList s
#else
	sl = reverse (S.toAscList s)
#endif

	go c _ [] = c
	go c newer (l:ls)
		| unique == emptyMetaData = go c newer ls
		| otherwise = go (l { value = unique } : c)
			(unionMetaData unique newer) ls
	  where
		older = value l
		unique = older `differenceMetaData` newer

{- Copies the metadata from the old key to the new key.
 -
 - The exact content of the metadata file is copied, so that the timestamps
 - remain the same, and because this is more space-efficient in the git
 - repository.
 -
 - Any metadata already attached to the new key is not preserved.
 -}
copyMetaData :: Key -> Key -> Annex ()
copyMetaData oldkey newkey
	| oldkey == newkey = noop
	| otherwise = do
		l <- getMetaDataLog oldkey
		unless (S.null l) $
			Annex.Branch.change (metaDataLogFile newkey) $
				const $ showLog l


code:
{- git-annex numcopies log
 -
 - Copyright 2014 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

{-# OPTIONS_GHC -fno-warn-orphans #-}

module Logs.NumCopies (
	setGlobalNumCopies,
	getGlobalNumCopies,
	globalNumCopiesLoad,
) where

import Common.Annex
import qualified Annex
import Types.NumCopies
import Logs
import Logs.SingleValue

instance SingleValueSerializable NumCopies where
	serialize (NumCopies n) = show n
	deserialize = NumCopies <$$> readish

setGlobalNumCopies :: NumCopies -> Annex ()
setGlobalNumCopies = setLog numcopiesLog

{- Value configured in the numcopies log. Cached for speed. -}
getGlobalNumCopies :: Annex (Maybe NumCopies)
getGlobalNumCopies = maybe globalNumCopiesLoad (return . Just)
	=<< Annex.getState Annex.globalnumcopies

globalNumCopiesLoad :: Annex (Maybe NumCopies)
globalNumCopiesLoad = do
	v <- getLog numcopiesLog
	Annex.changeState $ \s -> s { Annex.globalnumcopies = v }
	return v


code:
{- git-annex preferred content matcher configuration
 -
 - Copyright 2012-2014 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Logs.PreferredContent (
	preferredContentSet,
	requiredContentSet,
	groupPreferredContentSet,
	isPreferredContent,
	isRequiredContent,
	preferredContentMap,
	preferredContentMapRaw,
	requiredContentMap,
	requiredContentMapRaw,
	groupPreferredContentMapRaw,
	checkPreferredContentExpression,
	setStandardGroup,
	defaultStandardGroup,
	preferredRequiredMapsLoad,
) where

import qualified Data.Map as M
import qualified Data.Set as S
import Data.Either

import Common.Annex
import Logs.PreferredContent.Raw
import qualified Annex.Branch
import qualified Annex
import Logs
import Logs.UUIDBased
import Utility.Matcher hiding (tokens)
import Annex.FileMatcher
import Annex.UUID
import Types.Group
import Types.Remote (RemoteConfig)
import Logs.Group
import Logs.Remote
import Types.FileMatcher
import Types.StandardGroups
import Limit

{- Checks if a file is preferred content for the specified repository
 - (or the current repository if none is specified). -}
isPreferredContent :: Maybe UUID -> AssumeNotPresent -> Maybe Key -> AssociatedFile -> Bool -> Annex Bool
isPreferredContent = checkMap preferredContentMap

isRequiredContent :: Maybe UUID -> AssumeNotPresent -> Maybe Key -> AssociatedFile -> Bool -> Annex Bool
isRequiredContent = checkMap requiredContentMap

checkMap :: Annex (FileMatcherMap Annex) -> Maybe UUID -> AssumeNotPresent -> Maybe Key -> AssociatedFile -> Bool -> Annex Bool
checkMap getmap mu notpresent mkey afile def = do
	u <- maybe getUUID return mu
	m <- getmap
	case M.lookup u m of
		Nothing -> return def
		Just matcher -> checkMatcher matcher mkey afile notpresent def

preferredContentMap :: Annex (FileMatcherMap Annex)
preferredContentMap = maybe (fst <$> preferredRequiredMapsLoad) return
	=<< Annex.getState Annex.preferredcontentmap

requiredContentMap :: Annex (FileMatcherMap Annex)
requiredContentMap = maybe (snd <$> preferredRequiredMapsLoad) return
	=<< Annex.getState Annex.requiredcontentmap

preferredRequiredMapsLoad :: Annex (FileMatcherMap Annex, FileMatcherMap Annex)
preferredRequiredMapsLoad = do
	groupmap <- groupMap
	configmap <- readRemoteLog
	let genmap l gm = simpleMap
		. parseLogWithUUID ((Just .) . makeMatcher groupmap configmap gm)
		<$> Annex.Branch.get l
	pc <- genmap preferredContentLog =<< groupPreferredContentMapRaw
	rc <- genmap requiredContentLog M.empty
	-- Required content is implicitly also preferred content, so OR
	let m = M.unionWith MOr pc rc
	Annex.changeState $ \s -> s
		{ Annex.preferredcontentmap = Just m
		, Annex.requiredcontentmap = Just rc
		}
	return (m, rc)

{- This intentionally never fails, even on unparsable expressions,
 - because the configuration is shared among repositories and newer
 - versions of git-annex may add new features. -}
makeMatcher
	:: GroupMap
	-> M.Map UUID RemoteConfig
	-> M.Map Group PreferredContentExpression
	-> UUID
	-> PreferredContentExpression
	-> FileMatcher Annex
makeMatcher groupmap configmap groupwantedmap u = go True True
  where
	go expandstandard expandgroupwanted expr
		| null (lefts tokens) = generate $ rights tokens
		| otherwise = unknownMatcher u
	  where
		tokens = exprParser matchstandard matchgroupwanted groupmap configmap (Just u) expr
		matchstandard
			| expandstandard = maybe (unknownMatcher u) (go False False)
				(standardPreferredContent <$> getStandardGroup mygroups)
			| otherwise = unknownMatcher u
		matchgroupwanted
			| expandgroupwanted = maybe (unknownMatcher u) (go True False)
				(groupwanted mygroups)
			| otherwise = unknownMatcher u
		mygroups = fromMaybe S.empty (u `M.lookup` groupsByUUID groupmap)
		groupwanted s = case M.elems $ M.filterWithKey (\k _ -> S.member k s) groupwantedmap of
			[pc] -> Just pc
			_ -> Nothing

{- When a preferred content expression cannot be parsed, but is already
 - in the log (eg, put there by a newer version of git-annex),
 - the fallback behavior is to match only files that are currently present.
 -
 - This avoid unwanted/expensive changes to the content, until the problem
 - is resolved. -}
unknownMatcher :: UUID -> FileMatcher Annex
unknownMatcher u = generate [present]
  where
	present = Operation $ matchPresent (Just u)

{- Checks if an expression can be parsed, if not returns Just error -}
checkPreferredContentExpression :: PreferredContentExpression -> Maybe String
checkPreferredContentExpression expr = case parsedToMatcher tokens of
	Left e -> Just e
	Right _ -> Nothing
  where
	tokens = exprParser matchAll matchAll emptyGroupMap M.empty Nothing expr

{- Puts a UUID in a standard group, and sets its preferred content to use
 - the standard expression for that group (unless preferred content is
 - already set). -}
setStandardGroup :: UUID -> StandardGroup -> Annex ()
setStandardGroup u g = do
	groupSet u $ S.singleton $ fromStandardGroup g
	unlessM (isJust . M.lookup u <$> preferredContentMap) $
		preferredContentSet u "standard"

{- Avoids overwriting the UUID's standard group or preferred content
 - when it's already been configured. -}
defaultStandardGroup :: UUID -> StandardGroup -> Annex ()
defaultStandardGroup u g =
	unlessM (hasgroup <||> haspc) $
		setStandardGroup u g
  where
	hasgroup = not . S.null <$> lookupGroups u
	haspc = isJust . M.lookup u <$> preferredContentMap


code:
{- unparsed preferred content expressions
 -
 - Copyright 2012-2014 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Logs.PreferredContent.Raw where

import qualified Data.Map as M
import Data.Time.Clock.POSIX

import Common.Annex
import qualified Annex.Branch
import qualified Annex
import Logs
import Logs.UUIDBased
import Logs.MapLog
import Types.StandardGroups
import Types.Group

{- Changes the preferred content configuration of a remote. -}
preferredContentSet :: UUID -> PreferredContentExpression -> Annex ()
preferredContentSet = setLog preferredContentLog

requiredContentSet :: UUID -> PreferredContentExpression -> Annex ()
requiredContentSet = setLog requiredContentLog

setLog :: FilePath -> UUID -> PreferredContentExpression -> Annex ()
setLog logfile uuid@(UUID _) val = do
	ts <- liftIO getPOSIXTime
	Annex.Branch.change logfile $
		showLog id
		. changeLog ts uuid val
		. parseLog Just
	Annex.changeState $ \s -> s
		{ Annex.preferredcontentmap = Nothing
		, Annex.requiredcontentmap = Nothing
		}
setLog _ NoUUID _ = error "unknown UUID; cannot modify"

{- Changes the preferred content configuration of a group. -}
groupPreferredContentSet :: Group -> PreferredContentExpression -> Annex ()
groupPreferredContentSet g val = do
	ts <- liftIO getPOSIXTime
	Annex.Branch.change groupPreferredContentLog $
		showMapLog id id
		. changeMapLog ts g val
		. parseMapLog Just Just
	Annex.changeState $ \s -> s { Annex.preferredcontentmap = Nothing }

preferredContentMapRaw :: Annex (M.Map UUID PreferredContentExpression)
preferredContentMapRaw = simpleMap . parseLog Just
	<$> Annex.Branch.get preferredContentLog

requiredContentMapRaw :: Annex (M.Map UUID PreferredContentExpression)
requiredContentMapRaw = simpleMap . parseLog Just
	<$> Annex.Branch.get requiredContentLog

groupPreferredContentMapRaw :: Annex (M.Map Group PreferredContentExpression)
groupPreferredContentMapRaw = simpleMap . parseMapLog Just Just
	<$> Annex.Branch.get groupPreferredContentLog


code:
{- 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-2014 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Logs.Presence (
	module X,
	addLog,
	readLog,
	logNow,
	currentLog,
	historicalLog
) where

import Data.Time.Clock.POSIX

import Logs.Presence.Pure as X
import Common.Annex
import qualified Annex.Branch
import Git.Types (RefDate)

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 = parseLog <$$> Annex.Branch.get

{- 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

{- Reads a historical version of a log and returns the info that was in
 - effect at that time.
 -
 - The date is formatted as shown in gitrevisions man page.
 -}
historicalLog :: RefDate -> FilePath -> Annex [String]
historicalLog refdate file = map info . filterPresent . parseLog
	<$> Annex.Branch.getHistorical refdate file


code:
{- git-annex presence log, pure operations
 -
 - Copyright 2010-2013 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Logs.Presence.Pure where

import Data.Time.Clock.POSIX
import Data.Time
import System.Locale
import qualified Data.Map as M

import Common.Annex
import Utility.QuickCheck

data LogLine = LogLine {
	date :: POSIXTime,
	status :: LogStatus,
	info :: String
} deriving (Eq, Show)

data LogStatus = InfoPresent | InfoMissing
	deriving (Eq, Show, Bounded, Enum)

{- Parses a log file. Unparseable lines are ignored. -}
parseLog :: String -> [LogLine]
parseLog = mapMaybe parseline . lines
  where
	parseline l = LogLine
		<$> (utcTimeToPOSIXSeconds <$> parseTime defaultTimeLocale "%s%Qs" d)
		<*> parsestatus s
		<*> pure rest
	  where
		(d, pastd) = separate (== ' ') l
		(s, rest) = separate (== ' ') pastd
	parsestatus "1" = Just InfoPresent
	parsestatus "0" = Just InfoMissing
	parsestatus _ = Nothing

{- Generates a log file. -}
showLog :: [LogLine] -> String
showLog = unlines . map genline
  where
	genline (LogLine d s i) = unwords [show d, genstatus s, i]
	genstatus InfoPresent = "1"
	genstatus InfoMissing = "0"

{- Given a log, returns only the info that is are still in effect. -}
getLog :: String -> [String]
getLog = map info . filterPresent . parseLog

{- 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
	| better = M.insert i l m
	| otherwise = m
  where
	better = maybe True newer $ M.lookup i m
	newer l' = date l' <= date l
	i = info l

instance Arbitrary LogLine where
	arbitrary = LogLine
		<$> arbitrary
		<*> elements [minBound..maxBound]
		<*> arbitrary `suchThat` ('\n' `notElem`)

prop_parse_show_log :: [LogLine] -> Bool
prop_parse_show_log l = parseLog (showLog l) == l


code:
{- git-annex remote log
 -
 - Copyright 2011 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Logs.Remote (
	remoteLog,
	readRemoteLog,
	configSet,
	keyValToConfig,
	configToKeyVal,
	showConfig,
	parseConfig,

	prop_idempotent_configEscape,
	prop_parse_show_Config,
) 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
import Logs.UUIDBased

{- 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 = concatMap 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
		| not (null num) && ";" `isPrefixOf` r =
			chr (Prelude.read num) : unescape rest
		| otherwise =
			'&' : unescape s
	  where
		num = takeWhile isNumber s
		r = drop (length num) s
		rest = drop 1 r

{- for quickcheck -}
prop_idempotent_configEscape :: String -> Bool
prop_idempotent_configEscape s = s == (configUnEscape . configEscape) s

prop_parse_show_Config :: RemoteConfig -> Bool
prop_parse_show_Config c
	-- whitespace and '=' are not supported in keys
	| any (\k -> any isSpace k || elem '=' k) (M.keys c) = True
	| otherwise = parseConfig (showConfig c) ~~ Just c
  where
	normalize v = sort . M.toList <$> v
	a ~~ b = normalize a == normalize b


code:
{- Remote state logs.
 -
 - Copyright 2014 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Logs.RemoteState (
	getRemoteState,
	setRemoteState,
) where

import Common.Annex
import Logs
import Logs.UUIDBased
import qualified Annex.Branch

import qualified Data.Map as M
import Data.Time.Clock.POSIX

type RemoteState = String

setRemoteState :: UUID -> Key -> RemoteState -> Annex ()
setRemoteState u k s = do
	ts <- liftIO getPOSIXTime
	Annex.Branch.change (remoteStateLogFile k) $
		showLogNew id . changeLog ts u s . parseLogNew Just

getRemoteState :: UUID -> Key -> Annex (Maybe RemoteState)
getRemoteState u k = extract . parseLogNew Just
	<$> Annex.Branch.get (remoteStateLogFile k)
  where
	extract m = value <$> M.lookup u m


code:
{- git-annex scheduled activities log
 -
 - Copyright 2013 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Logs.Schedule (
	scheduleLog,
	scheduleSet,
	scheduleAdd,
	scheduleRemove,
	scheduleChange,
	scheduleGet,
	scheduleMap,
	getLastRunTimes,
	setLastRunTime,
) where

import qualified Data.Map as M
import qualified Data.Set as S
import Data.Time.Clock.POSIX
import Data.Time.LocalTime

import Common.Annex
import Types.ScheduledActivity
import qualified Annex.Branch
import Logs
import Logs.UUIDBased
import Utility.Tmp

scheduleSet :: UUID -> [ScheduledActivity] -> Annex ()
scheduleSet uuid@(UUID _) activities = do
	ts <- liftIO getPOSIXTime
	Annex.Branch.change scheduleLog $
		showLog id . changeLog ts uuid val . parseLog Just
  where
  	val = fromScheduledActivities activities
scheduleSet NoUUID _ = error "unknown UUID; cannot modify"

scheduleMap :: Annex (M.Map UUID [ScheduledActivity])
scheduleMap = simpleMap
	. parseLogWithUUID parser
	<$> Annex.Branch.get scheduleLog
  where
	parser _uuid = eitherToMaybe . parseScheduledActivities

scheduleGet :: UUID -> Annex (S.Set ScheduledActivity)
scheduleGet u = do
	m <- scheduleMap
	return $ maybe S.empty S.fromList (M.lookup u m)

scheduleRemove :: UUID -> ScheduledActivity -> Annex ()
scheduleRemove u activity = scheduleChange u $ S.delete activity

scheduleAdd :: UUID -> ScheduledActivity -> Annex ()
scheduleAdd u activity = scheduleChange u $ S.insert activity

scheduleChange :: UUID -> (S.Set ScheduledActivity -> S.Set ScheduledActivity) -> Annex ()
scheduleChange u a = scheduleSet u . S.toList . a =<< scheduleGet u

getLastRunTimes :: Annex (M.Map ScheduledActivity LocalTime)
getLastRunTimes = do
	f <- fromRepo gitAnnexScheduleState
	liftIO $ fromMaybe M.empty
		<$> catchDefaultIO Nothing (readish <$> readFile f)

setLastRunTime :: ScheduledActivity -> LocalTime -> Annex ()
setLastRunTime activity lastrun = do
	f <- fromRepo gitAnnexScheduleState
	liftIO . viaTmp writeFile f . show . M.insert activity lastrun
		=<< getLastRunTimes


code:
{- git-annex single-value log
 -
 - This is used to store a value in a way that can be union merged.
 -
 - A line of the log will look like: "timestamp value"
 -
 - The line with the newest timestamp wins.
 -
 - Copyright 2014 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Logs.SingleValue where

import Common.Annex
import qualified Annex.Branch

import qualified Data.Set as S
import Data.Time.Clock.POSIX
import Data.Time
import System.Locale

class SingleValueSerializable v where
	serialize :: v -> String
	deserialize :: String -> Maybe v

data LogEntry v = LogEntry
	{ changed :: POSIXTime
	, value :: v
	} deriving (Eq, Show, Ord)

type Log v = S.Set (LogEntry v)

showLog :: (SingleValueSerializable v) => Log v -> String
showLog = unlines . map showline . S.toList
  where
	showline (LogEntry t v) = unwords [show t, serialize v]

parseLog :: (Ord v, SingleValueSerializable v) => String -> Log v
parseLog = S.fromList . mapMaybe parse . lines
  where
	parse line = do
		let (ts, s) = splitword line
		date <- utcTimeToPOSIXSeconds <$> parseTime defaultTimeLocale "%s%Qs" ts
		v <- deserialize s
		Just (LogEntry date v)
	splitword = separate (== ' ')

newestValue :: Log v -> Maybe v
newestValue s
	| S.null s = Nothing
	| otherwise = Just (value $ S.findMax s)

readLog :: (Ord v, SingleValueSerializable v) => FilePath -> Annex (Log v)
readLog = parseLog <$$> Annex.Branch.get

getLog :: (Ord v, SingleValueSerializable v) => FilePath -> Annex (Maybe v)
getLog = newestValue <$$> readLog

setLog :: (SingleValueSerializable v) => FilePath -> v -> Annex ()
setLog f v = do
        now <- liftIO getPOSIXTime
        let ent = LogEntry now v
	Annex.Branch.change f $ \_old -> showLog (S.singleton ent)


code:
{- git-annex transfer information files and lock files
 -
 - Copyright 2012 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

{-# LANGUAGE CPP #-}

module Logs.Transfer where

import Common.Annex
import Annex.Perms
import Annex.Exception
import qualified Git
import Types.Key
import Utility.Metered
import Utility.Percentage
import Utility.QuickCheck
import Utility.PID
#ifdef mingw32_HOST_OS
import Utility.WinLock
#endif

import Data.Time.Clock
import Data.Time.Clock.POSIX
import Data.Time
import System.Locale
import Control.Concurrent

{- Enough information to uniquely identify a transfer, used as the filename
 - of the transfer information file. -}
data Transfer = Transfer
	{ transferDirection :: Direction
	, transferUUID :: UUID
	, transferKey :: Key
	}
	deriving (Eq, Ord, Read, Show)

{- Information about a Transfer, stored in the transfer information file.
 -
 - Note that the associatedFile may not correspond to a file in the local
 - git repository. It's some file, possibly relative to some directory,
 - of some repository, that was acted on to initiate the transfer.
 -}
data TransferInfo = TransferInfo
	{ startedTime :: Maybe POSIXTime
	, transferPid :: Maybe PID
	, transferTid :: Maybe ThreadId
	, transferRemote :: Maybe Remote
	, bytesComplete :: Maybe Integer
	, associatedFile :: Maybe FilePath
	, transferPaused :: Bool
	}
	deriving (Show, Eq, Ord)

stubTransferInfo :: TransferInfo
stubTransferInfo = TransferInfo Nothing Nothing Nothing Nothing Nothing Nothing False

data Direction = Upload | Download
	deriving (Eq, Ord, Read, Show)

showLcDirection :: Direction -> String
showLcDirection Upload = "upload"
showLcDirection Download = "download"

readLcDirection :: String -> Maybe Direction
readLcDirection "upload" = Just Upload
readLcDirection "download" = Just Download
readLcDirection _ = Nothing

describeTransfer :: Transfer -> TransferInfo -> String
describeTransfer t info = unwords
	[ show $ transferDirection t
	, show $ transferUUID t
	, fromMaybe (key2file $ transferKey t) (associatedFile info)
	, show $ bytesComplete info
	]

{- Transfers that will accomplish the same task. -}
equivilantTransfer :: Transfer -> Transfer -> Bool
equivilantTransfer t1 t2
	| transferDirection t1 == Download && transferDirection t2 == Download &&
	  transferKey t1 == transferKey t2 = True
	| otherwise = t1 == t2

percentComplete :: Transfer -> TransferInfo -> Maybe Percentage
percentComplete (Transfer { transferKey = key }) info =
	percentage <$> keySize key <*> Just (fromMaybe 0 $ bytesComplete info)

{- Generates a callback that can be called as transfer progresses to update
 - the transfer info file. Also returns the file it'll be updating, and a
 - MVar that can be used to read the number of bytesComplete. -}
mkProgressUpdater :: Transfer -> TransferInfo -> Annex (MeterUpdate, FilePath, MVar Integer)
mkProgressUpdater t info = do
	tfile <- fromRepo $ transferFile t
	_ <- tryAnnex $ createAnnexDirectory $ takeDirectory tfile
	mvar <- liftIO $ newMVar 0
	return (liftIO . updater tfile mvar, tfile, mvar)
  where
	updater tfile mvar b = modifyMVar_ mvar $ \oldbytes -> do
		let newbytes = fromBytesProcessed b
		if newbytes - oldbytes >= mindelta
			then do
				let info' = info { bytesComplete = Just newbytes }
				_ <- tryIO $ writeTransferInfoFile info' tfile
				return newbytes
			else return oldbytes
	{- The minimum change in bytesComplete that is worth
	 - updating a transfer info file for is 1% of the total
	 - keySize, rounded down. -}
	mindelta = case keySize (transferKey t) of
		Just sz -> sz `div` 100
		Nothing -> 100 * 1024 -- arbitrarily, 100 kb

startTransferInfo :: Maybe FilePath -> IO TransferInfo
startTransferInfo file = TransferInfo
	<$> (Just . utcTimeToPOSIXSeconds <$> getCurrentTime)
#ifndef mingw32_HOST_OS
	<*> pure Nothing -- pid not stored in file, so omitted for speed
#else
	<*> (Just <$> getPID)
#endif
	<*> pure Nothing -- tid ditto
	<*> pure Nothing -- not 0; transfer may be resuming
	<*> pure Nothing
	<*> pure file
	<*> pure False

{- If a transfer is still running, returns its TransferInfo. -}
checkTransfer :: Transfer -> Annex (Maybe TransferInfo)
checkTransfer t = do
	tfile <- fromRepo $ transferFile t
#ifndef mingw32_HOST_OS
	mode <- annexFileMode
	mfd <- liftIO $ catchMaybeIO $
		openFd (transferLockFile tfile) ReadOnly (Just mode) defaultFileFlags
	case mfd of
		Nothing -> return Nothing -- failed to open file; not running
		Just fd -> do
			locked <- liftIO $
				getLock fd (WriteLock, AbsoluteSeek, 0, 0)
			liftIO $ closeFd fd
			case locked of
				Nothing -> return Nothing
				Just (pid, _) -> liftIO $ catchDefaultIO Nothing $
					readTransferInfoFile (Just pid) tfile
#else
	v <- liftIO $ lockShared $ transferLockFile tfile
	liftIO $ case v of
		Nothing -> catchDefaultIO Nothing $
			readTransferInfoFile Nothing tfile
		Just lockhandle -> do
			dropLock lockhandle
			void $ tryIO $ removeFile $ transferLockFile tfile
			return Nothing
#endif

{- Gets all currently running transfers. -}
getTransfers :: Annex [(Transfer, TransferInfo)]
getTransfers = do
	transfers <- mapMaybe parseTransferFile . concat <$> findfiles
	infos <- mapM checkTransfer transfers
	return $ map (\(t, Just i) -> (t, i)) $
		filter running $ zip transfers infos
  where
	findfiles = liftIO . mapM dirContentsRecursive
		=<< mapM (fromRepo . transferDir) [Download, Upload]
	running (_, i) = isJust i

{- Gets failed transfers for a given remote UUID. -}
getFailedTransfers :: UUID -> Annex [(Transfer, TransferInfo)]
getFailedTransfers u = catMaybes <$> (liftIO . getpairs =<< concat <$> findfiles)
  where
	getpairs = mapM $ \f -> do
		let mt = parseTransferFile f
		mi <- readTransferInfoFile Nothing f
		return $ case (mt, mi) of
			(Just t, Just i) -> Just (t, i)
			_ -> Nothing
	findfiles = liftIO . mapM dirContentsRecursive
		=<< mapM (fromRepo . failedTransferDir u) [Download, Upload]

clearFailedTransfers :: UUID -> Annex [(Transfer, TransferInfo)]
clearFailedTransfers u = do
	failed <- getFailedTransfers u
	mapM_ (removeFailedTransfer . fst) failed
	return failed

removeFailedTransfer :: Transfer -> Annex ()
removeFailedTransfer t = do
	f <- fromRepo $ failedTransferFile t
	liftIO $ void $ tryIO $ removeFile f

recordFailedTransfer :: Transfer -> TransferInfo -> Annex ()
recordFailedTransfer t info = do
	failedtfile <- fromRepo $ failedTransferFile t
	createAnnexDirectory $ takeDirectory failedtfile
	liftIO $ writeTransferInfoFile info failedtfile

{- The transfer information file to use for a given Transfer. -}
transferFile :: Transfer -> Git.Repo -> FilePath
transferFile (Transfer direction u key) r = transferDir direction r
	</> filter (/= '/') (fromUUID u)
	</> keyFile key

{- The transfer information file to use to record a failed Transfer -}
failedTransferFile :: Transfer -> Git.Repo -> FilePath
failedTransferFile (Transfer direction u key) r = failedTransferDir u direction r
	</> keyFile key

{- The transfer lock file corresponding to a given transfer info file. -}
transferLockFile :: FilePath -> FilePath
transferLockFile infofile = let (d,f) = splitFileName infofile in
	combine d ("lck." ++ f)

{- Parses a transfer information filename to a Transfer. -}
parseTransferFile :: FilePath -> Maybe Transfer
parseTransferFile file
	| "lck." `isPrefixOf` takeFileName file = Nothing
	| otherwise = case drop (length bits - 3) bits of
		[direction, u, key] -> Transfer
			<$> readLcDirection direction
			<*> pure (toUUID u)
			<*> fileKey key
		_ -> Nothing
  where
	bits = splitDirectories file

writeTransferInfoFile :: TransferInfo -> FilePath -> IO ()
writeTransferInfoFile info tfile = writeFileAnyEncoding tfile $
	writeTransferInfo info

{- File format is a header line containing the startedTime and any
 - bytesComplete value. Followed by a newline and the associatedFile.
 -
 - On unix, the transferPid is not included; instead it is obtained
 - by looking at the process that locks the file.
 -
 - On windows, the transferPid is included, as a second line.
 -}
writeTransferInfo :: TransferInfo -> String
writeTransferInfo info = unlines
	[ (maybe "" show $ startedTime info) ++
	  (maybe "" (\b -> ' ' : show b) (bytesComplete info))
#ifdef mingw32_HOST_OS
	, maybe "" show (transferPid info)
#endif
	, fromMaybe "" $ associatedFile info -- comes last; arbitrary content
	]

readTransferInfoFile :: Maybe PID -> FilePath -> IO (Maybe TransferInfo)
readTransferInfoFile mpid tfile = catchDefaultIO Nothing $
	readTransferInfo mpid <$> readFileStrictAnyEncoding tfile

readTransferInfo :: Maybe PID -> String -> Maybe TransferInfo
readTransferInfo mpid s = TransferInfo
	<$> time
#ifdef mingw32_HOST_OS
	<*> pure (if isJust mpid then mpid else mpid')
#else
	<*> pure mpid
#endif
	<*> pure Nothing
	<*> pure Nothing
	<*> bytes
	<*> pure (if null filename then Nothing else Just filename)
	<*> pure False
  where
#ifdef mingw32_HOST_OS
	(firstline, otherlines) = separate (== '\n') s
	(secondline, rest) = separate (== '\n') otherlines
	mpid' = readish secondline
#else
	(firstline, rest) = separate (== '\n') s
#endif
	filename
		| end rest == "\n" = beginning rest
		| otherwise = rest
	bits = split " " firstline
	numbits = length bits
	time = if numbits > 0
		then Just <$> parsePOSIXTime =<< headMaybe bits
		else pure Nothing -- not failure
	bytes = if numbits > 1
		then Just <$> readish =<< headMaybe (drop 1 bits)
		else pure Nothing -- not failure

parsePOSIXTime :: String -> Maybe POSIXTime
parsePOSIXTime s = utcTimeToPOSIXSeconds
	<$> parseTime defaultTimeLocale "%s%Qs" s

{- The directory holding transfer information files for a given Direction. -}
transferDir :: Direction -> Git.Repo -> FilePath
transferDir direction r = gitAnnexTransferDir r </> showLcDirection direction

{- The directory holding failed transfer information files for a given
 - Direction and UUID -}
failedTransferDir :: UUID -> Direction -> Git.Repo -> FilePath
failedTransferDir u direction r = gitAnnexTransferDir r
	</> "failed"
	</> showLcDirection direction
	</> filter (/= '/') (fromUUID u)

instance Arbitrary TransferInfo where
	arbitrary = TransferInfo
		<$> arbitrary
		<*> arbitrary
		<*> pure Nothing -- cannot generate a ThreadID
		<*> pure Nothing -- remote not needed
		<*> arbitrary
		-- associated file cannot be empty (but can be Nothing)
		<*> arbitrary `suchThat` (/= Just "")
		<*> arbitrary

prop_read_write_transferinfo :: TransferInfo -> Bool
prop_read_write_transferinfo info
	| isJust (transferRemote info) = True -- remote not stored
	| isJust (transferTid info) = True -- tid not stored
	| otherwise = Just (info { transferPaused = False }) == info'
  where
	info' = readTransferInfo (transferPid info) (writeTransferInfo info)


code:
{- git-annex transitions log
 -
 - This is used to record transitions that have been performed on the
 - git-annex branch, and when the transition was first started.
 -
 - We can quickly detect when the local branch has already had an transition
 - done that is listed in the remote branch by checking that the local
 - branch contains the same transition, with the same or newer start time.
 -
 - Copyright 2013 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Logs.Transitions where

import Data.Time.Clock.POSIX
import Data.Time
import System.Locale
import qualified Data.Set as S

import Common.Annex

transitionsLog :: FilePath
transitionsLog = "transitions.log"

data Transition
	= ForgetGitHistory
	| ForgetDeadRemotes
	deriving (Show, Ord, Eq, Read)

data TransitionLine = TransitionLine
	{ transitionStarted :: POSIXTime
	, transition :: Transition
	} deriving (Show, Ord, Eq)

type Transitions = S.Set TransitionLine

describeTransition :: Transition -> String
describeTransition ForgetGitHistory = "forget git history"
describeTransition ForgetDeadRemotes = "forget dead remotes"

noTransitions :: Transitions
noTransitions = S.empty

addTransition :: POSIXTime -> Transition -> Transitions -> Transitions
addTransition ts t = S.insert $ TransitionLine ts t

showTransitions :: Transitions -> String
showTransitions = unlines . map showTransitionLine . S.elems

{- If the log contains new transitions we don't support, returns Nothing. -}
parseTransitions :: String -> Maybe Transitions
parseTransitions = check . map parseTransitionLine . lines
  where
  	check l
		| all isJust l = Just $ S.fromList $ catMaybes l
		| otherwise = Nothing

parseTransitionsStrictly :: String -> String -> Transitions
parseTransitionsStrictly source = fromMaybe badsource . parseTransitions
  where
	badsource = error $ "unknown transitions listed in " ++ source ++ "; upgrade git-annex!"

showTransitionLine :: TransitionLine -> String
showTransitionLine (TransitionLine ts t) = unwords [show t, show ts]

parseTransitionLine :: String -> Maybe TransitionLine
parseTransitionLine s = TransitionLine <$> pdate ds <*> readish ts
  where
  	ws = words s
  	ts = Prelude.head ws
	ds = unwords $ Prelude.tail ws
	pdate = utcTimeToPOSIXSeconds <$$> parseTime defaultTimeLocale "%s%Qs"

combineTransitions :: [Transitions] -> Transitions
combineTransitions = S.unions

transitionList :: Transitions -> [Transition]
transitionList = map transition . S.elems

{- Typically ran with Annex.Branch.change, but we can't import Annex.Branch
 - here since it depends on this module. -}
recordTransitions :: (FilePath -> (String -> String) -> Annex ()) -> Transitions -> Annex ()
recordTransitions changer t = changer transitionsLog $
	showTransitions . S.union t . parseTransitionsStrictly "local"


code:
{- git-annex trust log
 -
 - Copyright 2010-2012 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Logs.Trust (
	module X,
	trustLog,
	TrustLevel(..),
	trustGet,
	trustMap,
	trustSet,
	trustPartition,
	trustExclude,
	lookupTrust,
	trustMapLoad,
	trustMapRaw,
) 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
import Logs.UUIDBased
import Remote.List
import qualified Types.Remote
import Logs.Trust.Pure as X

{- Returns a list of UUIDs that the trustLog indicates have the
 - specified trust level.
 - Note that the list can be incomplete for SemiTrusted, since that's
 - the default. -}
trustGet :: TrustLevel -> Annex [UUID]
trustGet level = M.keys . M.filter (== level) <$> trustMap

{- Changes the trust level for a uuid in the trustLog. -}
trustSet :: UUID -> TrustLevel -> Annex ()
trustSet uuid@(UUID _) level = do
	ts <- liftIO getPOSIXTime
	Annex.Branch.change trustLog $
		showLog showTrustLog .
			changeLog ts uuid level .
				parseLog (Just . parseTrustLog)
	Annex.changeState $ \s -> s { Annex.trustmap = Nothing }
trustSet NoUUID _ = error "unknown UUID; cannot modify"

{- Returns the TrustLevel of a given repo UUID. -}
lookupTrust :: UUID -> Annex TrustLevel
lookupTrust u = (fromMaybe SemiTrusted . M.lookup u) <$> trustMap

{- Partitions a list of UUIDs to those matching a TrustLevel and not. -}
trustPartition :: TrustLevel -> [UUID] -> Annex ([UUID], [UUID])
trustPartition level ls
	| level == SemiTrusted = do
		t <- trustGet Trusted
		u <- trustGet UnTrusted
		d <- trustGet DeadTrusted
		let uncandidates = t ++ u ++ d
		return $ partition (`notElem` uncandidates) ls
	| otherwise = do
		candidates <- trustGet level
		return $ partition (`elem` candidates) ls

{- Filters UUIDs to those not matching a TrustLevel. -}
trustExclude :: TrustLevel -> [UUID] -> Annex [UUID]
trustExclude level ls = snd <$> trustPartition level ls

{- trustLog in a map, overridden with any values from forcetrust or
 - the git config. The map is cached for speed. -}
trustMap :: Annex TrustMap
trustMap = maybe trustMapLoad return =<< Annex.getState Annex.trustmap

{- Loads the map, updating the cache, -}
trustMapLoad :: Annex TrustMap
trustMapLoad = do
	overrides <- Annex.getState Annex.forcetrust
	logged <- trustMapRaw
	configured <- M.fromList . catMaybes
		<$> (map configuredtrust <$> remoteList)
	let m = M.union overrides $ M.union configured logged
	Annex.changeState $ \s -> s { Annex.trustmap = Just m }
	return m
  where
	configuredtrust r = (\l -> Just (Types.Remote.uuid r, l))
		=<< readTrustLevel
		=<< remoteAnnexTrustLevel (Types.Remote.gitconfig r)

{- Does not include forcetrust or git config values, just those from the
 - log file. -}
trustMapRaw :: Annex TrustMap
trustMapRaw = calcTrustMap <$> Annex.Branch.get trustLog


code:
{- git-annex trust log, pure operations
 -
 - Copyright 2010-2013 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Logs.Trust.Pure where

import Common.Annex
import Types.TrustLevel
import Logs.UUIDBased

calcTrustMap :: String -> TrustMap
calcTrustMap = simpleMap . parseLog (Just . parseTrustLog)

{- The trust.log used to only list trusted repos, without a field for the
 - trust status, which is why this defaults to Trusted. -}
parseTrustLog :: String -> TrustLevel
parseTrustLog s = maybe Trusted parse $ headMaybe $ words s
  where
	parse "1" = Trusted
	parse "0" = UnTrusted
	parse "X" = DeadTrusted
	parse _ = SemiTrusted

showTrustLog :: TrustLevel -> String
showTrustLog Trusted = "1"
showTrustLog UnTrusted = "0"
showTrustLog DeadTrusted = "X"
showTrustLog SemiTrusted = "?"

prop_parse_show_TrustLog :: Bool
prop_parse_show_TrustLog = all check [minBound .. maxBound]
  where
	check l = parseTrustLog (showTrustLog l) == l


code:
{- 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-2012 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Logs.UUID (
	uuidLog,
	describeUUID,
	recordUUID,
	uuidMap,
	uuidMapLoad
) where

import qualified Data.Map as M
import Data.Time.Clock.POSIX

import Types.UUID
import Common.Annex
import qualified Annex
import qualified Annex.Branch
import Logs
import Logs.UUIDBased
import qualified Annex.UUID

{- Records a description for a uuid in the log. -}
describeUUID :: UUID -> String -> Annex ()
describeUUID uuid desc = do
	ts <- liftIO getPOSIXTime
	Annex.Branch.change uuidLog $
		showLog id . changeLog ts uuid desc . fixBadUUID . parseLog Just

{- Temporarily here to fix badly formatted uuid logs generated by
 - versions 3.20111105 and 3.20111025.
 -
 - Those logs contain entries with the UUID and description flipped.
 - Due to parsing, if the description is multiword, only the first
 - will be taken to be the UUID. So, if the UUID of an entry does
 - not look like a UUID, and the last word of the description does,
 - flip them back.
 -}
fixBadUUID :: Log String -> Log String
fixBadUUID = M.fromList . map fixup . M.toList
  where
	fixup (k, v)
		| isbad = (fixeduuid, LogEntry (Date $ newertime v) fixedvalue)
		| otherwise = (k, v)
	  where
		kuuid = fromUUID k
		isbad = not (isuuid kuuid) && not (null ws) && isuuid lastword
		ws = words $ value v
		lastword = Prelude.last ws
		fixeduuid = toUUID lastword
		fixedvalue = unwords $ kuuid: Prelude.init ws
	-- For the fixed line to take precidence, it should be
	-- slightly newer, but only slightly.
	newertime (LogEntry (Date d) _) = d + minimumPOSIXTimeSlice
	newertime (LogEntry Unknown _) = minimumPOSIXTimeSlice
	minimumPOSIXTimeSlice = 0.000001
	isuuid s = length s == 36 && length (split "-" s) == 5

{- Records the uuid in the log, if it's not already there. -}
recordUUID :: UUID -> Annex ()
recordUUID u = go . M.lookup u =<< uuidMap
  where
	go (Just "") = set
	go Nothing = set
	go _ = noop
	set = describeUUID u ""

{- The map is cached for speed. -}
uuidMap :: Annex UUIDMap
uuidMap = maybe uuidMapLoad return =<< Annex.getState Annex.uuidmap

{- Read the uuidLog into a simple Map.
 -
 - The UUID of the current repository is included explicitly, since
 - it may not have been described and so otherwise would not appear. -}
uuidMapLoad :: Annex UUIDMap
uuidMapLoad = do
	m <- (simpleMap . parseLog Just) <$> Annex.Branch.get uuidLog
	u <- Annex.UUID.getUUID
	let m' = M.insertWith' preferold u "" m
	Annex.changeState $ \s -> s { Annex.uuidmap = Just m' }
	return m'
  where
	preferold = flip const


code:
{- git-annex uuid-based logs
 -
 - This is used to store information about UUIDs 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.
 -
 - New uuid based logs instead use the form: "timestamp UUID INFO"
 -
 - Copyright 2011-2013 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Logs.UUIDBased (
	Log,
	LogEntry(..),
	TimeStamp(..),
	parseLog,
	parseLogNew,
	parseLogWithUUID,
	showLog,
	showLogNew,
	changeLog,
	addLog,
	simpleMap,
) where

import qualified Data.Map as M
import Data.Time.Clock.POSIX
import Data.Time
import System.Locale

import Common
import Types.UUID
import Logs.MapLog

type Log v = MapLog UUID v

showLog :: (v -> String) -> Log v -> String
showLog shower = unlines . map showpair . M.toList
  where
	showpair (k, LogEntry (Date p) v) =
		unwords [fromUUID k, shower v, tskey ++ show p]
	showpair (k, LogEntry Unknown v) =
		unwords [fromUUID k, shower v]

parseLog :: (String -> Maybe a) -> String -> Log a
parseLog = parseLogWithUUID . const

parseLogWithUUID :: (UUID -> String -> Maybe a) -> String -> Log a
parseLogWithUUID parser = M.fromListWith best . mapMaybe parse . lines
  where
	parse line
		-- This is a workaround for a bug that caused
		-- NoUUID items to be stored in the log.
		-- It can be removed at any time; is just here to clean
		-- up logs where that happened temporarily.
		| " " `isPrefixOf` line = Nothing
		| null ws = Nothing
		| otherwise = parser u (unwords info) >>= makepair
	  where
		makepair v = Just (u, LogEntry ts v)
		ws = words line
		u = toUUID $ Prelude.head ws
		t = Prelude.last ws
		ts
			| tskey `isPrefixOf` t =
				pdate $ drop 1 $ dropWhile (/= '=') t
			| otherwise = Unknown
		info
			| ts == Unknown = drop 1 ws
			| otherwise = drop 1 $ beginning ws
		pdate s = case parseTime defaultTimeLocale "%s%Qs" s of
			Nothing -> Unknown
			Just d -> Date $ utcTimeToPOSIXSeconds d

showLogNew :: (v -> String) -> Log v -> String
showLogNew = showMapLog fromUUID

parseLogNew :: (String -> Maybe v) -> String -> Log v
parseLogNew = parseMapLog (Just . toUUID)

changeLog :: POSIXTime -> UUID -> v -> Log v -> Log v
changeLog = changeMapLog

addLog :: UUID -> LogEntry v -> Log v -> Log v
addLog = addMapLog

tskey :: String
tskey = "timestamp="


code:
{- git-annex unused log file
 -
 - This file is stored locally in .git/annex/, not in the git-annex branch.
 -
 - The format: "int key timestamp"
 -
 - The int is a short, stable identifier that the user can use to
 - refer to this key. (Equivilant to a filename.)
 -
 - The timestamp indicates when the key was first determined to be unused.
 - Older versions of the log omit the timestamp.
 -
 - Copyright 2010-2014 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

{-# LANGUAGE CPP #-}

module Logs.Unused (
	UnusedMap,
	updateUnusedLog,
	readUnusedLog,
	readUnusedMap,
	dateUnusedLog,
	unusedKeys,
	unusedKeys',
	setUnusedKeys,
) where

import qualified Data.Map as M
import qualified Data.Set as S
import Data.Time.Clock.POSIX
import Data.Time
import System.Locale

import Common.Annex
import qualified Annex
import Types.Key
import Utility.Tmp

-- everything that is stored in the unused log
type UnusedLog = M.Map Key (Int, Maybe POSIXTime)

-- used to look up unused keys specified by the user
type UnusedMap = M.Map Int Key

log2map :: UnusedLog -> UnusedMap
log2map = M.fromList . map (\(k, (i, _t)) -> (i, k)) . M.toList

map2log :: POSIXTime -> UnusedMap -> UnusedLog
map2log t = M.fromList . map (\(i, k) -> (k, (i, Just t))) . M.toList

{- Only keeps keys that are in the new log, but uses any timestamps
 - those keys had in the old log. -}
preserveTimestamps :: UnusedLog -> UnusedLog -> UnusedLog
preserveTimestamps oldl newl = M.intersection (M.unionWith oldts oldl newl) newl
  where
	oldts _old@(_, ts) _new@(int, _) = (int, ts)

updateUnusedLog :: FilePath -> UnusedMap -> Annex ()
updateUnusedLog prefix m = do
	oldl <- readUnusedLog prefix
	newl <- preserveTimestamps oldl . flip map2log m <$> liftIO getPOSIXTime
	writeUnusedLog prefix newl

writeUnusedLog :: FilePath -> UnusedLog -> Annex ()
writeUnusedLog prefix l = do
	logfile <- fromRepo $ gitAnnexUnusedLog prefix
	liftIO $ viaTmp writeFileAnyEncoding logfile $ unlines $ map format $ M.toList l
  where
	format (k, (i, Just t)) = show i ++ " " ++ key2file k ++ " " ++ show t
	format (k, (i, Nothing)) = show i ++ " " ++ key2file k

readUnusedLog :: FilePath -> Annex UnusedLog
readUnusedLog prefix = do
	f <- fromRepo $ gitAnnexUnusedLog prefix
	ifM (liftIO $ doesFileExist f)
		( M.fromList . mapMaybe parse . lines
			<$> liftIO (readFileStrictAnyEncoding f)
		, return M.empty
		)
  where
	parse line = case (readish sint, file2key skey, utcTimeToPOSIXSeconds <$> parseTime defaultTimeLocale "%s%Qs" ts) of
		(Just int, Just key, mtimestamp) -> Just (key, (int, mtimestamp))
		_ -> Nothing
	  where
		(sint, rest) = separate (== ' ') line
		(rts, rskey) = separate (== ' ') (reverse rest)
		skey = reverse rskey
		ts = reverse rts

readUnusedMap :: FilePath -> Annex UnusedMap
readUnusedMap = log2map <$$> readUnusedLog

dateUnusedLog :: FilePath -> Annex (Maybe UTCTime)
#if MIN_VERSION_directory(1,2,0)
dateUnusedLog prefix = do
	f <- fromRepo $ gitAnnexUnusedLog prefix
	liftIO $ catchMaybeIO $ getModificationTime f
#else
-- old ghc's getModificationTime returned a ClockTime
dateUnusedLog _prefix = return Nothing
#endif

{- Set of unused keys. This is cached for speed. -}
unusedKeys :: Annex (S.Set Key)
unusedKeys = maybe (setUnusedKeys =<< unusedKeys') return
	=<< Annex.getState Annex.unusedkeys

unusedKeys' :: Annex [Key]
unusedKeys' = M.keys <$> readUnusedLog ""

setUnusedKeys :: [Key] -> Annex (S.Set Key)
setUnusedKeys ks = do
	let v = S.fromList ks
	Annex.changeState $ \s -> s { Annex.unusedkeys = Just v }
	return v


code:
{- git-annex recent views log
 -
 - The most recently accessed view comes first.
 -
 - This file is stored locally in .git/annex/, not in the git-annex branch.
 -
 - Copyright 2014 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Logs.View (
	currentView,
	setView,
	removeView,
	recentViews,
	branchView,
	is_branchView,
	prop_branchView_legal,
) where

import Common.Annex
import Types.View
import Types.MetaData
import qualified Git
import qualified Git.Branch
import qualified Git.Ref
import Git.Types
import Utility.Tmp

import qualified Data.Set as S
import Data.Char

setView :: View -> Annex ()
setView v = do
	old <- take 99 . filter (/= v) <$> recentViews
	writeViews (v : old)

writeViews :: [View] -> Annex ()
writeViews l = do
	f <- fromRepo gitAnnexViewLog
	liftIO $ viaTmp writeFile f $ unlines $ map show l

removeView :: View -> Annex ()
removeView v = writeViews =<< filter (/= v) <$> recentViews

recentViews :: Annex [View]
recentViews = do
	f <- fromRepo gitAnnexViewLog
	liftIO $ mapMaybe readish . lines <$> catchDefaultIO [] (readFile f)

{- Gets the currently checked out view, if there is one. -}
currentView :: Annex (Maybe View)
currentView = go =<< inRepo Git.Branch.current
  where
	go (Just b) | branchViewPrefix `isPrefixOf` fromRef b =
		headMaybe . filter (\v -> branchView v == b) <$> recentViews
	go _ = return Nothing

branchViewPrefix :: String
branchViewPrefix = "refs/heads/views"

{- Generates a git branch name for a View.
 -
 - There is no guarantee that each view gets a unique branch name,
 - but the branch name is used to express the view as well as possible.
 -}
branchView :: View -> Git.Branch
branchView view
	| null name = Git.Ref branchViewPrefix
	| otherwise = Git.Ref $ branchViewPrefix ++ "/" ++ name
  where
	name = intercalate ";" $ map branchcomp (viewComponents view)
	branchcomp c
		| viewVisible c = branchcomp' c
		| otherwise = "(" ++ branchcomp' c ++ ")"
	branchcomp' (ViewComponent metafield viewfilter _) =concat
		[ forcelegal (fromMetaField metafield)
		, branchvals viewfilter
		]
	branchvals (FilterValues set) = '=' : branchset set
	branchvals (FilterGlob glob) = '=' : forcelegal glob
	branchvals (ExcludeValues set) = "!=" ++ branchset set
	branchset = intercalate ","
		. map (forcelegal . fromMetaValue)
		. S.toList
	forcelegal s
		| Git.Ref.legal True s = s
		| otherwise = map (\c -> if isAlphaNum c then c else '_') s

is_branchView :: Git.Branch -> Bool
is_branchView (Ref b)
	| b == branchViewPrefix = True
	| otherwise = (branchViewPrefix ++ "/") `isPrefixOf` b

prop_branchView_legal :: View -> Bool
prop_branchView_legal = Git.Ref.legal False . fromRef . branchView


code:
{- Web url logs.
 -
 - Copyright 2011, 2013 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Logs.Web (
	URLString,
	webUUID,
	getUrls,
	setUrlPresent,
	setUrlMissing,
	knownUrls,
	Downloader(..),
	getDownloader,
	setDownloader,
) where

import qualified Data.ByteString.Lazy.Char8 as L
import Data.Tuple.Utils

import Common.Annex
import Logs
import Logs.Presence
import Logs.Location
import qualified Annex.Branch
import Annex.CatFile
import qualified Git
import qualified Git.LsFiles

type URLString = String

-- Dummy uuid for the whole web. Do not alter.
webUUID :: UUID
webUUID = UUID "00000000-0000-0000-0000-000000000001"

{- Gets all urls that a key might be available from. -}
getUrls :: Key -> Annex [URLString]
getUrls key = go $ urlLogFile key : oldurlLogs key
  where
	go [] = return []
	go (l:ls) = do
		us <- currentLog l
		if null us
			then go ls
			else return us

setUrlPresent :: Key -> URLString -> Annex ()
setUrlPresent key url = do
	us <- getUrls key
	unless (url `elem` us) $ do
		addLog (urlLogFile key) =<< logNow InfoPresent url
		-- update location log to indicate that the web has the key
		logChange key webUUID InfoPresent

setUrlMissing :: Key -> URLString -> Annex ()
setUrlMissing key url = do
	addLog (urlLogFile key) =<< logNow InfoMissing url
	whenM (null <$> getUrls key) $
		logChange key webUUID InfoMissing

{- Finds all known urls. -}
knownUrls :: Annex [URLString]
knownUrls = do
	{- Ensure the git-annex branch's index file is up-to-date and
	 - any journaled changes are reflected in it, since we're going
	 - to query its index directly. -}
	Annex.Branch.update
	Annex.Branch.commit "update"
	Annex.Branch.withIndex $ do
		top <- fromRepo Git.repoPath
		(l, cleanup) <- inRepo $ Git.LsFiles.stagedDetails [top]
		r <- mapM (geturls . snd3) $ filter (isUrlLog . fst3) l
		void $ liftIO cleanup
		return $ concat r
  where
	geturls Nothing = return []
  	geturls (Just logsha) = getLog . L.unpack <$> catObject logsha

data Downloader = DefaultDownloader | QuviDownloader

{- Determines the downloader for an URL.
 -
 - Some URLs are not downloaded by normal means, and this is indicated
 - by prefixing them with downloader: when they are recorded in the url
 - logs. -}
getDownloader :: URLString -> (URLString, Downloader)
getDownloader u = case separate (== ':') u of
	("quvi", u') -> (u', QuviDownloader)
	_ -> (u, DefaultDownloader)

setDownloader :: URLString -> Downloader -> URLString
setDownloader u DefaultDownloader = u
setDownloader u QuviDownloader = "quvi:" ++ u