code:
{- management of the git-annex journal
 -
 - The journal is used to queue up changes before they are committed to the
 - git-annex branch. Among other things, it ensures that if git-annex is
 - interrupted, its recorded data is not lost.
 -
 - Copyright 2011-2013 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

{-# LANGUAGE CPP #-}

module Annex.Journal where

import Common.Annex
import Annex.Exception
import qualified Git
import Annex.Perms
import Annex.LockFile

{- Records content for a file in the branch to the journal.
 -
 - Using the journal, rather than immediatly staging content to the index
 - avoids git needing to rewrite the index after every change.
 -
 - The file in the journal is updated atomically, which allows
 - getJournalFileStale to always return a consistent journal file
 - content, although possibly not the most current one.
 -}
setJournalFile :: JournalLocked -> FilePath -> String -> Annex ()
setJournalFile _jl file content = do
	tmp <- fromRepo gitAnnexTmpMiscDir
	createAnnexDirectory =<< fromRepo gitAnnexJournalDir
	createAnnexDirectory tmp
	-- journal file is written atomically
	jfile <- fromRepo $ journalFile file
	let tmpfile = tmp </> takeFileName jfile
	liftIO $ do
		withFile tmpfile WriteMode $ \h -> do
			fileEncoding h
#ifdef mingw32_HOST_OS
			hSetNewlineMode h noNewlineTranslation
#endif
			hPutStr h content
		moveFile tmpfile jfile

{- Gets any journalled content for a file in the branch. -}
getJournalFile :: JournalLocked -> FilePath -> Annex (Maybe String)
getJournalFile _jl = getJournalFileStale

{- Without locking, this is not guaranteed to be the most recent
 - version of the file in the journal, so should not be used as a basis for
 - changes. -}
getJournalFileStale :: FilePath -> Annex (Maybe String)
getJournalFileStale file = inRepo $ \g -> catchMaybeIO $
	readFileStrictAnyEncoding $ journalFile file g

{- List of files that have updated content in the journal. -}
getJournalledFiles :: JournalLocked -> Annex [FilePath]
getJournalledFiles jl = map fileJournal <$> getJournalFiles jl

getJournalledFilesStale :: Annex [FilePath]
getJournalledFilesStale = map fileJournal <$> getJournalFilesStale

{- List of existing journal files. -}
getJournalFiles :: JournalLocked -> Annex [FilePath]
getJournalFiles _jl = getJournalFilesStale

{- List of existing journal files, but without locking, may miss new ones
 - just being added, or may have false positives if the journal is staged
 - as it is run. -}
getJournalFilesStale :: Annex [FilePath]
getJournalFilesStale = do
	g <- gitRepo
	fs <- liftIO $ catchDefaultIO [] $
		getDirectoryContents $ gitAnnexJournalDir g
	return $ filter (`notElem` [".", ".."]) fs

withJournalHandle :: (DirectoryHandle -> IO a) -> Annex a
withJournalHandle a = do
	d <- fromRepo gitAnnexJournalDir
	bracketIO (openDirectory d) closeDirectory (liftIO . a)

{- Checks if there are changes in the journal. -}
journalDirty :: Annex Bool
journalDirty = do
	d <- fromRepo gitAnnexJournalDir
	liftIO $
		(not <$> isDirectoryEmpty d)
			`catchIO` (const $ doesDirectoryExist d)

{- Produces a filename to use in the journal for a file on the branch.
 -
 - The journal typically won't have a lot of files in it, so the hashing
 - used in the branch is not necessary, and all the files are put directly
 - in the journal directory.
 -}
journalFile :: FilePath -> Git.Repo -> FilePath
journalFile file repo = gitAnnexJournalDir repo </> concatMap mangle file
  where
	mangle c
		| c == pathSeparator = "_"
		| c == '_' = "__"
		| otherwise = [c]

{- Converts a journal file (relative to the journal dir) back to the
 - filename on the branch. -}
fileJournal :: FilePath -> FilePath
fileJournal = replace [pathSeparator, pathSeparator] "_" .
	replace "_" [pathSeparator]

{- Sentinal value, only produced by lockJournal; required
 - as a parameter by things that need to ensure the journal is
 - locked. -}
data JournalLocked = ProduceJournalLocked

{- Runs an action that modifies the journal, using locking to avoid
 - contention with other git-annex processes. -}
lockJournal :: (JournalLocked -> Annex a) -> Annex a
lockJournal a = withExclusiveLock gitAnnexJournalLock $ a ProduceJournalLocked


code:
{- git-annex links to content
 -
 - On file systems that support them, symlinks are used.
 -
 - On other filesystems, git instead stores the symlink target in a regular
 - file.
 -
 - Copyright 2013 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Annex.Link where

import Common.Annex
import qualified Annex
import qualified Git.HashObject
import qualified Git.UpdateIndex
import qualified Annex.Queue
import Git.Types
import Git.FilePath

type LinkTarget = String

{- Checks if a file is a link to a key. -}
isAnnexLink :: FilePath -> Annex (Maybe Key)
isAnnexLink file = maybe Nothing (fileKey . takeFileName) <$> getAnnexLinkTarget file

{- Gets the link target of a symlink.
 -
 - On a filesystem that does not support symlinks, fall back to getting the
 - link target by looking inside the file.
 -
 - Returns Nothing if the file is not a symlink, or not a link to annex
 - content.
 -}
getAnnexLinkTarget :: FilePath -> Annex (Maybe LinkTarget)
getAnnexLinkTarget file = ifM (coreSymlinks <$> Annex.getGitConfig)
	( check readSymbolicLink $
		return Nothing
	, check readSymbolicLink $
		check probefilecontent $
			return Nothing
	)
  where
	check getlinktarget fallback = do
		v <- liftIO $ catchMaybeIO $ getlinktarget file
		case v of
			Just l
				| isLinkToAnnex (fromInternalGitPath l) -> return v
				| otherwise -> return Nothing
			Nothing -> fallback

	probefilecontent f = withFile f ReadMode $ \h -> do
		fileEncoding h
		-- The first 8k is more than enough to read; link
		-- files are small.
		s <- take 8192 <$> hGetContents h
		-- If we got the full 8k, the file is too large
		if length s == 8192
			then return ""
			else
				-- If there are any NUL or newline
				-- characters, or whitespace, we
				-- certianly don't have a link to a
				-- git-annex key.
				return $ if any (`elem` s) "\0\n\r \t"
					then ""
					else s

makeAnnexLink :: LinkTarget -> FilePath -> Annex ()
makeAnnexLink = makeGitLink

{- Creates a link on disk.
 -
 - On a filesystem that does not support symlinks, writes the link target
 - to a file. Note that git will only treat the file as a symlink if
 - it's staged as such, so use addAnnexLink when adding a new file or
 - modified link to git.
 -}
makeGitLink :: LinkTarget -> FilePath -> Annex ()
makeGitLink linktarget file = ifM (coreSymlinks <$> Annex.getGitConfig)
	( liftIO $ do
		void $ tryIO $ removeFile file
		createSymbolicLink linktarget file
	, liftIO $ writeFile file linktarget
	)

{- Creates a link on disk, and additionally stages it in git. -}
addAnnexLink :: LinkTarget -> FilePath -> Annex ()
addAnnexLink linktarget file = do
	makeAnnexLink linktarget file
	stageSymlink file =<< hashSymlink linktarget

{- Injects a symlink target into git, returning its Sha. -}
hashSymlink :: LinkTarget -> Annex Sha
hashSymlink linktarget = inRepo $ Git.HashObject.hashObject BlobObject $
	toInternalGitPath linktarget

hashSymlink' :: Git.HashObject.HashObjectHandle -> LinkTarget -> Annex Sha
hashSymlink' h linktarget = liftIO $ Git.HashObject.hashBlob h $
	toInternalGitPath linktarget

{- Stages a symlink to the annex, using a Sha of its target. -}
stageSymlink :: FilePath -> Sha -> Annex ()
stageSymlink file sha =
	Annex.Queue.addUpdateIndex =<<
		inRepo (Git.UpdateIndex.stageSymlink file sha)

repo_name: kakafarm/git

license: unknown


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

{-# LANGUAGE CPP #-}

module Annex.LockFile (
	lockFileShared,
	unlockFile,
	getLockPool,
	withExclusiveLock,
) where

import Common.Annex
import Annex
import Types.LockPool
import qualified Git
import Annex.Exception
import Annex.Perms

import qualified Data.Map as M

#ifdef mingw32_HOST_OS
import Utility.WinLock
#endif

{- Create a specified lock file, and takes a shared lock, which is retained
 - in the pool. -}
lockFileShared :: FilePath -> Annex ()
lockFileShared file = go =<< fromLockPool file
  where
	go (Just _) = noop -- already locked
	go Nothing = do
#ifndef mingw32_HOST_OS
		mode <- annexFileMode
		lockhandle <- liftIO $ noUmask mode $
			openFd file ReadOnly (Just mode) defaultFileFlags
		liftIO $ waitToSetLock lockhandle (ReadLock, AbsoluteSeek, 0, 0)
#else
		lockhandle <- liftIO $ waitToLock $ lockShared file
#endif
		changeLockPool $ M.insert file lockhandle

unlockFile :: FilePath -> Annex ()
unlockFile file = maybe noop go =<< fromLockPool file
  where
	go lockhandle = do
#ifndef mingw32_HOST_OS
		liftIO $ closeFd lockhandle
#else
		liftIO $ dropLock lockhandle
#endif
		changeLockPool $ M.delete file

getLockPool :: Annex LockPool
getLockPool = getState lockpool

fromLockPool :: FilePath -> Annex (Maybe LockHandle)
fromLockPool file = M.lookup file <$> getLockPool

changeLockPool :: (LockPool -> LockPool) -> Annex ()
changeLockPool a = do
	m <- getLockPool
	changeState $ \s -> s { lockpool = a m }

{- Runs an action with an exclusive lock held. If the lock is already
 - held, blocks until it becomes free. -}
withExclusiveLock :: (Git.Repo -> FilePath) -> Annex a -> Annex a
withExclusiveLock getlockfile a = do
	lockfile <- fromRepo getlockfile
	createAnnexDirectory $ takeDirectory lockfile
	mode <- annexFileMode
	bracketIO (lock lockfile mode) unlock (const a)
  where
#ifndef mingw32_HOST_OS
	lock lockfile mode = do
		l <- noUmask mode $ createFile lockfile mode
		waitToSetLock l (WriteLock, AbsoluteSeek, 0, 0)
		return l
	unlock = closeFd
#else
	lock lockfile _mode = waitToLock $ lockExclusive lockfile
	unlock = dropLock
#endif


code:
{- making local repositories (used by webapp mostly)
 -
 - Copyright 2012-2014 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Annex.MakeRepo where

import Assistant.WebApp.Common
import Annex.Init
import qualified Git.Construct
import qualified Git.Config
import qualified Git.Command
import qualified Git.Branch
import qualified Annex
import Annex.UUID
import Annex.Direct
import Types.StandardGroups
import Logs.PreferredContent
import qualified Annex.Branch

{- Makes a new git repository. Or, if a git repository already
 - exists, returns False. -}
makeRepo :: FilePath -> Bool -> IO Bool
makeRepo path bare = ifM (probeRepoExists path)
	( return False
	, do
		(transcript, ok) <-
			processTranscript "git" (toCommand params) Nothing
		unless ok $
			error $ "git init failed!\nOutput:\n" ++ transcript
		return True
	)
  where
	baseparams = [Param "init", Param "--quiet"]
	params
		| bare = baseparams ++ [Param "--bare", File path]
		| otherwise = baseparams ++ [File path]

{- Runs an action in the git repository in the specified directory. -}
inDir :: FilePath -> Annex a -> IO a
inDir dir a = do
	state <- Annex.new =<< Git.Config.read =<< Git.Construct.fromPath dir
	Annex.eval state a

{- Creates a new repository, and returns its UUID. -}
initRepo :: Bool -> Bool -> FilePath -> Maybe String -> Maybe StandardGroup -> IO UUID
initRepo True primary_assistant_repo dir desc mgroup = inDir dir $ do
	initRepo' desc mgroup
	{- Initialize the master branch, so things that expect
	 - to have it will work, before any files are added. -}
	unlessM (Git.Config.isBare <$> gitRepo) $
		void $ inRepo $ Git.Branch.commitCommand Git.Branch.AutomaticCommit
			[ Param "--quiet"
			, Param "--allow-empty"
			, Param "-m"
			, Param "created repository"
			]
	{- Repositories directly managed by the assistant use direct mode.
	 -
	 - Automatic gc is disabled, as it can be slow. Insted, gc is done
	 - once a day.
	 -}
	when primary_assistant_repo $ do
		setDirect True
		inRepo $ Git.Command.run
			[Param "config", Param "gc.auto", Param "0"]
	getUUID
{- Repo already exists, could be a non-git-annex repo though so
 - still initialize it. -}
initRepo False _ dir desc mgroup = inDir dir $ do
	initRepo' desc mgroup
	getUUID

initRepo' :: Maybe String -> Maybe StandardGroup -> Annex ()
initRepo' desc mgroup = unlessM isInitialized $ do
	initialize desc
	u <- getUUID
	maybe noop (defaultStandardGroup u) mgroup
	{- Ensure branch gets committed right away so it is
	 - available for merging immediately. -}
	Annex.Branch.commit "update"

{- Checks if a git repo exists at a location. -}
probeRepoExists :: FilePath -> IO Bool
probeRepoExists dir = isJust <$>
	catchDefaultIO Nothing (Git.Construct.checkForRepo dir)


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

module Annex.MetaData (
	genMetaData,
	dateMetaData,
	module X
) where

import Common.Annex
import qualified Annex
import Types.MetaData as X
import Annex.MetaData.StandardFields as X
import Logs.MetaData
import Annex.CatFile

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

{- Adds metadata for a file that has just been ingested into the
 - annex, but has not yet been committed to git.
 -
 - When the file has been modified, the metadata is copied over
 - from the old key to the new key. Note that it looks at the old key as
 - committed to HEAD -- the new key may or may not have already been staged
 - in th annex.
 -
 - Also, can generate new metadata, if configured to do so.
 -}
genMetaData :: Key -> FilePath -> FileStatus -> Annex ()
genMetaData key file status = do
	maybe noop (flip copyMetaData key) =<< catKeyFileHEAD file
	whenM (annexGenMetaData <$> Annex.getGitConfig) $ do
		curr <- getCurrentMetaData key
		addMetaData key (dateMetaData mtime curr)
  where
	mtime = posixSecondsToUTCTime $ realToFrac $ modificationTime status

{- Generates metadata for a file's date stamp.
 - Does not overwrite any existing metadata values. -}
dateMetaData :: UTCTime -> MetaData -> MetaData
dateMetaData mtime old = MetaData $ M.fromList $ filter isnew
	[ (yearMetaField, S.singleton $ toMetaValue $ show y)
	, (monthMetaField, S.singleton $ toMetaValue $ show m)
	]
  where
	isnew (f, _) = S.null (currentMetaDataValues f old)
	(y, m, _d) = toGregorian $ utctDay $ mtime


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

module Annex.MetaData.StandardFields (
	tagMetaField,
	yearMetaField,
	monthMetaField,
	lastChangedField,
	mkLastChangedField,
	isLastChangedField
) where

import Types.MetaData

import Data.List

tagMetaField :: MetaField
tagMetaField = mkMetaFieldUnchecked "tag"

yearMetaField :: MetaField
yearMetaField = mkMetaFieldUnchecked "year"

monthMetaField :: MetaField
monthMetaField = mkMetaFieldUnchecked "month"

lastChangedField :: MetaField
lastChangedField = mkMetaFieldUnchecked lastchanged

mkLastChangedField :: MetaField -> MetaField
mkLastChangedField f = mkMetaFieldUnchecked (fromMetaField f ++ lastchangedSuffix)

isLastChangedField :: MetaField -> Bool
isLastChangedField f
	| f == lastChangedField = True
	| otherwise = lastchanged `isSuffixOf` s && s /= lastchangedSuffix
  where
	s = fromMetaField f

lastchanged :: String
lastchanged = "lastchanged"

lastchangedSuffix :: String
lastchangedSuffix = "-lastchanged"


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

{-# LANGUAGE CPP #-}

module Annex.Notification (NotifyWitness, notifyTransfer, notifyDrop) where

import Common.Annex
import Logs.Transfer
#ifdef WITH_DBUS_NOTIFICATIONS
import qualified Annex
import Types.DesktopNotify
import qualified DBus.Notify as Notify
import qualified DBus.Client
#endif

-- Witness that notification has happened.
data NotifyWitness = NotifyWitness

{- Wrap around an action that performs a transfer, which may run multiple
 - attempts. Displays notification when supported and when the user asked
 - for it. -}
notifyTransfer :: Direction -> Maybe FilePath -> (NotifyWitness -> Annex Bool) -> Annex Bool
notifyTransfer _ Nothing a = a NotifyWitness
#ifdef WITH_DBUS_NOTIFICATIONS
notifyTransfer direction (Just f) a = do
	wanted <- Annex.getState Annex.desktopnotify
	if (notifyStart wanted || notifyFinish wanted)
		then do
			client <- liftIO DBus.Client.connectSession
			startnotification <- liftIO $ if notifyStart wanted
				then Just <$> Notify.notify client (startedTransferNote direction f)
				else pure Nothing
			ok <- a NotifyWitness
			when (notifyFinish wanted) $ liftIO $ void $ maybe
				(Notify.notify client $ finishedTransferNote ok direction f)
				(\n -> Notify.replace client n $ finishedTransferNote ok direction f)
				startnotification
			return ok
		else a NotifyWitness
#else
notifyTransfer _ (Just _) a = do a NotifyWitness
#endif

notifyDrop :: Maybe FilePath -> Bool -> Annex ()
notifyDrop Nothing _ = noop
#ifdef WITH_DBUS_NOTIFICATIONS
notifyDrop (Just f) ok = do
	wanted <- Annex.getState Annex.desktopnotify
	when (notifyFinish wanted) $ liftIO $ do
		client <- DBus.Client.connectSession
		void $ Notify.notify client (droppedNote ok f)
#else
notifyDrop (Just _) _ = noop
#endif

#ifdef WITH_DBUS_NOTIFICATIONS
startedTransferNote :: Direction -> FilePath -> Notify.Note
startedTransferNote Upload   = mkNote Notify.Transfer Notify.Low iconUpload
	"Uploading"
startedTransferNote Download = mkNote Notify.Transfer Notify.Low iconDownload
	"Downloading"

finishedTransferNote :: Bool -> Direction -> FilePath -> Notify.Note
finishedTransferNote False Upload   = mkNote Notify.TransferError Notify.Normal iconFailure
	"Failed to upload"
finishedTransferNote False Download = mkNote Notify.TransferError Notify.Normal iconFailure
	"Failed to download"
finishedTransferNote True  Upload   = mkNote Notify.TransferComplete Notify.Low iconSuccess
	"Finished uploading"
finishedTransferNote True  Download = mkNote Notify.TransferComplete Notify.Low iconSuccess
	"Finished downloading"

droppedNote :: Bool -> FilePath -> Notify.Note
droppedNote False = mkNote Notify.TransferError Notify.Normal iconFailure
	"Failed to drop"
droppedNote True  = mkNote Notify.TransferComplete Notify.Low iconSuccess
	"Dropped"

iconUpload, iconDownload, iconFailure, iconSuccess :: String
iconUpload   = "network-transmit"
iconDownload = "network-receive"
iconFailure  = "dialog-error"
iconSuccess  = "git-annex"  -- Is there a standard icon for success/completion?

mkNote :: Notify.Category -> Notify.UrgencyLevel -> String -> String -> FilePath -> Notify.Note
mkNote category urgency icon desc path = Notify.blankNote
	{ Notify.appName = "git-annex"
	, Notify.appImage = Just (Notify.Icon icon)
	, Notify.summary = desc ++ " " ++ path
	, Notify.hints =
		[ Notify.Category category
		, Notify.Urgency urgency
		, Notify.SuppressSound True
		]
	}
#endif


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

{-# LANGUAGE CPP #-}

module Annex.Path where

import Common
import Config.Files
import System.Environment

{- A fully qualified path to the currently running git-annex program.
 -
 - getExecutablePath is available since ghc 7.4.2. On OSs it supports
 - well, it returns the complete path to the program. But, on other OSs,
 - it might return just the basename.
 -}
programPath :: IO (Maybe FilePath)
programPath = do
#if MIN_VERSION_base(4,6,0)
	exe <- getExecutablePath
	p <- if isAbsolute exe
		then return exe
		else readProgramFile
#else
	p <- readProgramFile
#endif
	-- In case readProgramFile returned just the command name,
	-- fall back to finding it in PATH.
	searchPath p


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

module Annex.Perms (
	setAnnexFilePerm,
	setAnnexDirPerm,
	annexFileMode,
	createAnnexDirectory,
	noUmask,
	createContentDir,
	freezeContentDir,
	thawContentDir,
	modifyContent,
) where

import Common.Annex
import Utility.FileMode
import Git.SharedRepository
import qualified Annex
import Annex.Exception
import Config

import System.Posix.Types

withShared :: (SharedRepository -> Annex a) -> Annex a
withShared a = maybe startup a =<< Annex.getState Annex.shared
  where
	startup = do
		shared <- fromRepo getSharedRepository
		Annex.changeState $ \s -> s { Annex.shared = Just shared }
		a shared

setAnnexFilePerm :: FilePath -> Annex ()
setAnnexFilePerm = setAnnexPerm False

setAnnexDirPerm :: FilePath -> Annex ()
setAnnexDirPerm = setAnnexPerm True

{- Sets appropriate file mode for a file or directory in the annex,
 - other than the content files and content directory. Normally,
 - use the default mode, but with core.sharedRepository set,
 - allow the group to write, etc. -}
setAnnexPerm :: Bool -> FilePath -> Annex ()
setAnnexPerm isdir file = unlessM crippledFileSystem $
	withShared $ liftIO . go
  where
	go GroupShared = modifyFileMode file $ addModes $
		groupSharedModes ++
		if isdir then [ ownerExecuteMode, groupExecuteMode ] else []
	go AllShared = modifyFileMode file $ addModes $
		readModes ++
		[ ownerWriteMode, groupWriteMode ] ++
		if isdir then executeModes else []
	go _ = noop

{- Gets the appropriate mode to use for creating a file in the annex
 - (other than content files, which are locked down more). -}
annexFileMode :: Annex FileMode
annexFileMode = withShared $ return . go
  where
	go GroupShared = sharedmode
	go AllShared = combineModes (sharedmode:readModes)
	go _ = stdFileMode
	sharedmode = combineModes groupSharedModes

{- Creates a directory inside the gitAnnexDir, including any parent
 - directories. Makes directories with appropriate permissions. -}
createAnnexDirectory :: FilePath -> Annex ()
createAnnexDirectory dir = traverse dir [] =<< top
  where
	top = parentDir <$> fromRepo gitAnnexDir
	traverse d below stop
		| d `equalFilePath` stop = done
		| otherwise = ifM (liftIO $ doesDirectoryExist d)
			( done
			, traverse (parentDir d) (d:below) stop
			)
	  where
		done = forM_ below $ \p -> do
			liftIO $ createDirectoryIfMissing True p
			setAnnexDirPerm p

{- Blocks writing to the directory an annexed file is in, to prevent the
 - file accidentially being deleted. However, if core.sharedRepository
 - is set, this is not done, since the group must be allowed to delete the
 - file.
 -}
freezeContentDir :: FilePath -> Annex ()
freezeContentDir file = unlessM crippledFileSystem $
	liftIO . go =<< fromRepo getSharedRepository
  where
	dir = parentDir file
	go GroupShared = groupWriteRead dir
	go AllShared = groupWriteRead dir
	go _ = preventWrite dir

thawContentDir :: FilePath -> Annex ()
thawContentDir file = unlessM crippledFileSystem $
	liftIO $ allowWrite $ parentDir file

{- Makes the directory tree to store an annexed file's content,
 - with appropriate permissions on each level. -}
createContentDir :: FilePath -> Annex ()
createContentDir dest = do
	unlessM (liftIO $ doesDirectoryExist dir) $
		createAnnexDirectory dir
	-- might have already existed with restricted perms
	unlessM crippledFileSystem $
		liftIO $ allowWrite dir
  where
	dir = parentDir dest

{- Creates the content directory for a file if it doesn't already exist,
 - or thaws it if it does, then runs an action to modify the file, and
 - finally, freezes the content directory. -}
modifyContent :: FilePath -> Annex a -> Annex a
modifyContent f a = do
	createContentDir f -- also thaws it
	v <- tryAnnex a
	freezeContentDir f
	either throwAnnex return v


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

module Annex.Queue (
	addCommand,
	addUpdateIndex,
	flush,
	flushWhenFull,
	size
) where

import Common.Annex
import Annex hiding (new)
import qualified Git.Queue
import qualified Git.UpdateIndex

{- Adds a git command to the queue. -}
addCommand :: String -> [CommandParam] -> [FilePath] -> Annex ()
addCommand command params files = do
	q <- get
	store <=< inRepo $ Git.Queue.addCommand command params files q

{- Adds an update-index stream to the queue. -}
addUpdateIndex :: Git.UpdateIndex.Streamer -> Annex ()
addUpdateIndex streamer = do
	q <- get
	store <=< inRepo $ Git.Queue.addUpdateIndex streamer q

{- Runs the queue if it is full. Should be called periodically. -}
flushWhenFull :: Annex ()
flushWhenFull = do
	q <- get
	when (Git.Queue.full q) flush

{- Runs (and empties) the queue. -}
flush :: Annex ()
flush = do
	q <- get
	unless (0 == Git.Queue.size q) $ do
		showStoringStateAction
		q' <- inRepo $ Git.Queue.flush q
		store q'

{- Gets the size of the queue. -}
size :: Annex Int
size = Git.Queue.size <$> get

get :: Annex Git.Queue.Queue
get = maybe new return =<< getState repoqueue

new :: Annex Git.Queue.Queue
new = do
	q <- Git.Queue.new . annexQueueSize <$> getGitConfig
	store q
	return q

store :: Git.Queue.Queue -> Annex ()
store q = changeState $ \s -> s { repoqueue = Just q }


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

{-# LANGUAGE Rank2Types #-}

module Annex.Quvi where

import Common.Annex
import qualified Annex
import Utility.Quvi
import Utility.Url

withQuviOptions :: forall a. Query a -> [QuviParam] -> URLString -> Annex a
withQuviOptions a ps url = do
	v <- quviVersion
	opts <- map Param . annexQuviOptions <$> Annex.getGitConfig
	liftIO $ a v (map (\mkp -> mkp v) ps++opts) url

quviSupported :: URLString -> Annex Bool
quviSupported u = liftIO . flip supported u =<< quviVersion

quviVersion :: Annex QuviVersion
quviVersion = go =<< Annex.getState Annex.quviversion
  where
	go (Just v) = return v
	go Nothing = do
		v <- liftIO probeVersion
		Annex.changeState $ \s -> s { Annex.quviversion = Just v }
		return v


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

module Annex.ReplaceFile where

import Common.Annex
import Annex.Perms
import Annex.Exception

{- Replaces a possibly already existing file with a new version,
 - atomically, by running an action.
 -
 - The action is passed a temp file, which it can write to, and once
 - done the temp file is moved into place.
 -
 - The action can throw an IO exception, in which case the temp file
 - will be deleted, and the existing file will be preserved.
 -
 - Throws an IO exception when it was unable to replace the file.
 -}
replaceFile :: FilePath -> (FilePath -> Annex ()) -> Annex ()
replaceFile file action = replaceFileOr file action (liftIO . nukeFile)

{- If unable to replace the file with the temp file, runs the
 - rollback action, which is responsible for cleaning up the temp file. -}
replaceFileOr :: FilePath -> (FilePath -> Annex ()) -> (FilePath -> Annex ()) -> Annex ()
replaceFileOr file action rollback = do
	tmpdir <- fromRepo gitAnnexTmpMiscDir
	void $ createAnnexDirectory tmpdir
	bracketAnnex (liftIO $ setup tmpdir) rollback $ \tmpfile -> do
		action tmpfile
		liftIO $ catchIO (rename tmpfile file) (fallback tmpfile)
  where
  	setup tmpdir = do
		(tmpfile, h) <- openTempFileWithDefaultPermissions tmpdir "tmp"
		hClose h
		return tmpfile
	fallback tmpfile _ = do
		createDirectoryIfMissing True $ parentDir file
		moveFile tmpfile file


code:
{- git-annex ssh interface, with connection caching
 -
 - Copyright 2012-2014 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

{-# LANGUAGE CPP #-}

module Annex.Ssh (
	sshCachingOptions,
	sshCacheDir,
	sshReadPort,
	forceSshCleanup,
	sshCachingEnv,
	sshCachingTo,
	inRepoWithSshCachingTo,
	runSshCaching,
	sshAskPassEnv,
	runSshAskPass
) where

import qualified Data.Map as M
import Data.Hash.MD5
import System.Exit

import Common.Annex
import Annex.LockFile
import qualified Build.SysConfig as SysConfig
import qualified Annex
import qualified Git
import qualified Git.Url
import Config
import Config.Files
import Utility.Env
import Types.CleanupActions
import Annex.Index (addGitEnv)
#ifndef mingw32_HOST_OS
import Annex.Perms
#endif

{- Generates parameters to ssh to a given host (or user@host) on a given
 - port, with connection caching. -}
sshCachingOptions :: (String, Maybe Integer) -> [CommandParam] -> Annex [CommandParam]
sshCachingOptions (host, port) opts = go =<< sshInfo (host, port)
  where
	go (Nothing, params) = ret params
	go (Just socketfile, params) = do
		prepSocket socketfile
		ret params
	ret ps = return $ ps ++ opts ++ portParams port ++ [Param "-T"]

{- Returns a filename to use for a ssh connection caching socket, and
 - parameters to enable ssh connection caching. -}
sshInfo :: (String, Maybe Integer) -> Annex (Maybe FilePath, [CommandParam])
sshInfo (host, port) = go =<< sshCacheDir
  where
	go Nothing = return (Nothing, [])
	go (Just dir) = do
		r <- liftIO $ bestSocketPath $ dir </> hostport2socket host port
		return $ case r of
			Nothing -> (Nothing, [])
			Just socketfile -> (Just socketfile, sshConnectionCachingParams socketfile)

{- Given an absolute path to use for a socket file,
 - returns whichever is shorter of that or the relative path to the same
 - file.
 -
 - If no path can be constructed that is a valid socket, returns Nothing. -}
bestSocketPath :: FilePath -> IO (Maybe FilePath)
bestSocketPath abssocketfile = do
	relsocketfile <- liftIO $ relPathCwdToFile abssocketfile
	let socketfile = if length abssocketfile <= length relsocketfile
		then abssocketfile
		else relsocketfile
	return $ if valid_unix_socket_path (socketfile ++ sshgarbage)
			then Just socketfile
			else Nothing
  where
  	-- ssh appends a 16 char extension to the socket when setting it
	-- up, which needs to be taken into account when checking
	-- that a valid socket was constructed.
  	sshgarbage = replicate (1+16) 'X'

sshConnectionCachingParams :: FilePath -> [CommandParam]
sshConnectionCachingParams socketfile =
	[ Param "-S", Param socketfile
	, Params "-o ControlMaster=auto -o ControlPersist=yes"
	]

{- ssh connection caching creates sockets, so will not work on a
 - crippled filesystem. A GIT_ANNEX_TMP_DIR can be provided to use
 - a different filesystem. -}
sshCacheDir :: Annex (Maybe FilePath)
sshCacheDir
	| SysConfig.sshconnectioncaching = ifM crippledFileSystem
		( maybe (return Nothing) usetmpdir =<< gettmpdir
		, ifM (fromMaybe True . annexSshCaching <$> Annex.getGitConfig)
			( Just <$> fromRepo gitAnnexSshDir
			, return Nothing
			)
		)
	| otherwise = return Nothing
  where
	gettmpdir = liftIO $ getEnv "GIT_ANNEX_TMP_DIR"
	usetmpdir tmpdir = liftIO $ catchMaybeIO $ do
		let socktmp = tmpdir </> "ssh"
		createDirectoryIfMissing True socktmp
		return socktmp

portParams :: Maybe Integer -> [CommandParam]
portParams Nothing = []
portParams (Just port) = [Param "-p", Param $ show port]

{- Prepare to use a socket file. Locks a lock file to prevent
 - other git-annex processes from stopping the ssh on this socket. -}
prepSocket :: FilePath -> Annex ()
prepSocket socketfile = do
	-- If the lock pool is empty, this is the first ssh of this
	-- run. There could be stale ssh connections hanging around
	-- from a previous git-annex run that was interrupted.
	whenM (not . any isLock . M.keys <$> getLockPool)
		sshCleanup
	-- Cleanup at end of this run.
	Annex.addCleanup SshCachingCleanup sshCleanup

	liftIO $ createDirectoryIfMissing True $ parentDir socketfile
	lockFileShared $ socket2lock socketfile

enumSocketFiles :: Annex [FilePath]
enumSocketFiles = go =<< sshCacheDir
  where
	go Nothing = return []
	go (Just dir) = liftIO $ filter (not . isLock)
		<$> catchDefaultIO [] (dirContents dir)

{- Stop any unused ssh connection caching processes. -}
sshCleanup :: Annex ()
sshCleanup = mapM_ cleanup =<< enumSocketFiles
  where
	cleanup socketfile = do
#ifndef mingw32_HOST_OS
		-- Drop any shared lock we have, and take an
		-- exclusive lock, without blocking. If the lock
		-- succeeds, nothing is using this ssh, and it can
		-- be stopped.
		--
		-- After ssh is stopped cannot remove the lock file;
		-- other processes may be waiting on our exclusive
		-- lock to use it.
		let lockfile = socket2lock socketfile
		unlockFile lockfile
		mode <- annexFileMode
		fd <- liftIO $ noUmask mode $
			openFd lockfile ReadWrite (Just mode) defaultFileFlags
		v <- liftIO $ tryIO $
			setLock fd (WriteLock, AbsoluteSeek, 0, 0)
		case v of
			Left _ -> noop
			Right _ -> forceStopSsh socketfile
		liftIO $ closeFd fd
#else
		forceStopSsh socketfile
#endif

{- Stop all ssh connection caching processes, even when they're in use. -}
forceSshCleanup :: Annex ()
forceSshCleanup = mapM_ forceStopSsh =<< enumSocketFiles

forceStopSsh :: FilePath -> Annex ()
forceStopSsh socketfile = do
	let (dir, base) = splitFileName socketfile
	let params = sshConnectionCachingParams base
	-- "ssh -O stop" is noisy on stderr even with -q
	void $ liftIO $ catchMaybeIO $
		withQuietOutput createProcessSuccess $
			(proc "ssh" $ toCommand $
				[ Params "-O stop"
				] ++ params ++ [Param "localhost"])
				{ cwd = Just dir }
	liftIO $ nukeFile socketfile

{- This needs to be as short as possible, due to limitations on the length
 - of the path to a socket file. At the same time, it needs to be unique
 - for each host.
 -}
hostport2socket :: String -> Maybe Integer -> FilePath
hostport2socket host Nothing = hostport2socket' host
hostport2socket host (Just port) = hostport2socket' $ host ++ "!" ++ show port
hostport2socket' :: String -> FilePath
hostport2socket' s
	| length s > lengthofmd5s = md5s (Str s)
	| otherwise = s
  where
	lengthofmd5s = 32

socket2lock :: FilePath -> FilePath
socket2lock socket = socket ++ lockExt

isLock :: FilePath -> Bool
isLock f = lockExt `isSuffixOf` f

lockExt :: String
lockExt = ".lock"

{- This is the size of the sun_path component of sockaddr_un, which
 - is the limit to the total length of the filename of a unix socket.
 -
 - On Linux, this is 108. On OSX, 104. TODO: Probe
 -}
sizeof_sockaddr_un_sun_path :: Int
sizeof_sockaddr_un_sun_path = 100

{- Note that this looks at the true length of the path in bytes, as it will
 - appear on disk. -}
valid_unix_socket_path :: FilePath -> Bool
valid_unix_socket_path f = length (decodeW8 f) < sizeof_sockaddr_un_sun_path

{- Parses the SSH port, and returns the other OpenSSH options. If
 - several ports are found, the last one takes precedence. -}
sshReadPort :: [String] -> (Maybe Integer, [String])
sshReadPort params = (port, reverse args)
  where
	(port,args) = aux (Nothing, []) params
	aux (p,ps) [] = (p,ps)
	aux (_,ps) ("-p":p:rest) = aux (readPort p, ps) rest
	aux (p,ps) (q:rest) | "-p" `isPrefixOf` q = aux (readPort $ drop 2 q, ps) rest
			    | otherwise = aux (p,q:ps) rest
	readPort p = fmap fst $ listToMaybe $ reads p

{- When this env var is set, git-annex runs ssh with parameters
 - to use the socket file that the env var contains.
 -
 - This is a workaround for GIT_SSH not being able to contain
 - additional parameters to pass to ssh. -}
sshCachingEnv :: String
sshCachingEnv = "GIT_ANNEX_SSHCACHING"

{- Enables ssh caching for git push/pull to a particular
 - remote git repo. (Can safely be used on non-ssh remotes.)
 -
 - Like inRepo, the action is run with the local git repo.
 - But here it's a modified version, with gitEnv to set GIT_SSH=git-annex,
 - and sshCachingEnv set so that git-annex will know what socket
 - file to use. -}
inRepoWithSshCachingTo :: Git.Repo -> (Git.Repo -> IO a) -> Annex a
inRepoWithSshCachingTo remote a =
	liftIO . a =<< sshCachingTo remote =<< gitRepo

{- To make any git commands be run with ssh caching enabled,
 - alters the local Git.Repo's gitEnv to set GIT_SSH=git-annex,
 - and set sshCachingEnv so that git-annex will know what socket
 - file to use. -}
sshCachingTo :: Git.Repo -> Git.Repo -> Annex Git.Repo
sshCachingTo remote g
	| not (Git.repoIsUrl remote) || Git.repoIsHttp remote = uncached
	| otherwise = case Git.Url.hostuser remote of
		Nothing -> uncached
		Just host -> do
			(msockfile, _) <- sshInfo (host, Git.Url.port remote)
			case msockfile of
				Nothing -> return g
				Just sockfile -> do
					command <- liftIO readProgramFile
					prepSocket sockfile
					liftIO $ do
						g' <- addGitEnv g sshCachingEnv sockfile
						addGitEnv g' "GIT_SSH" command
  where
	uncached = return g

runSshCaching :: [String] -> FilePath -> IO ()
runSshCaching args sockfile = do
	let args' = toCommand (sshConnectionCachingParams sockfile) ++ args
	let p = proc "ssh" args'
	exitWith =<< waitForProcess . processHandle =<< createProcess p

{- When this env var is set, git-annex is being used as a ssh-askpass
 - program, and should read the password from the specified location,
 - and output it for ssh to read. -}
sshAskPassEnv :: String
sshAskPassEnv = "GIT_ANNEX_SSHASKPASS"

runSshAskPass :: FilePath -> IO ()
runSshAskPass passfile = putStrLn =<< readFile passfile


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

module Annex.TaggedPush where

import Common.Annex
import qualified Remote
import qualified Annex.Branch
import qualified Git
import qualified Git.Ref
import qualified Git.Command
import qualified Git.Branch
import Utility.Base64

{- Converts a git branch into a branch that is tagged with a UUID, typically
 - the UUID of the repo that will be pushing it, and possibly with other
 - information.
 -
 - Pushing to branches on the remote that have our uuid in them is ugly,
 - but it reserves those branches for pushing by us, and so our pushes will
 - never conflict with other pushes.
 -
 - To avoid cluttering up the branch display, the branch is put under
 - refs/synced/, rather than the usual refs/remotes/
 -
 - Both UUIDs and Base64 encoded data are always legal to be used in git
 - refs, per git-check-ref-format.
 -}
toTaggedBranch :: UUID -> Maybe String -> Git.Branch -> Git.Branch
toTaggedBranch u info b = Git.Ref $ intercalate "/" $ catMaybes
	[ Just "refs/synced"
	, Just $ fromUUID u
	, toB64 <$> info
	, Just $ Git.fromRef $ Git.Ref.base b
	]

fromTaggedBranch :: Git.Branch -> Maybe (UUID, Maybe String)
fromTaggedBranch b = case split "/" $ Git.fromRef b of
	("refs":"synced":u:info:_base) ->
		Just (toUUID u, fromB64Maybe info)
	("refs":"synced":u:_base) ->
		Just (toUUID u, Nothing)
	_ -> Nothing
  where

taggedPush :: UUID -> Maybe String -> Git.Ref -> Remote -> Git.Repo -> IO Bool
taggedPush u info branch remote = Git.Command.runBool
        [ Param "push"
        , Param $ Remote.name remote
	{- Using forcePush here is safe because we "own" the tagged branch
	 - we're pushing; it has no other writers. Ensures it is pushed
	 - even if it has been rewritten by a transition. -}
        , Param $ Git.Branch.forcePush $ refspec Annex.Branch.name
        , Param $ refspec branch
        ]
  where
	refspec b = Git.fromRef b ++ ":" ++ Git.fromRef (toTaggedBranch u info b)


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

{-# LANGUAGE CPP #-}

module Annex.Transfer (
	module X,
	upload,
	download,
	runTransfer,
	noRetry,
	forwardRetry,
) where

import Common.Annex
import Logs.Transfer as X
import Annex.Notification as X
import Annex.Perms
import Annex.Exception
import Utility.Metered
#ifdef mingw32_HOST_OS
import Utility.WinLock
#endif

import Control.Concurrent

upload :: UUID -> Key -> AssociatedFile -> RetryDecider -> (MeterUpdate -> Annex Bool) -> NotifyWitness -> Annex Bool
upload u key f d a _witness = runTransfer (Transfer Upload u key) f d a

download :: UUID -> Key -> AssociatedFile -> RetryDecider -> (MeterUpdate -> Annex Bool) -> NotifyWitness -> Annex Bool
download u key f d a _witness = runTransfer (Transfer Download u key) f d a

{- Runs a transfer action. Creates and locks the lock file while the
 - action is running, and stores info in the transfer information
 - file.
 -
 - If the transfer action returns False, the transfer info is
 - left in the failedTransferDir.
 -
 - If the transfer is already in progress, returns False.
 -
 - An upload can be run from a read-only filesystem, and in this case
 - no transfer information or lock file is used.
 -}
runTransfer :: Transfer -> Maybe FilePath -> RetryDecider -> (MeterUpdate -> Annex Bool) -> Annex Bool
runTransfer t file shouldretry a = do
	info <- liftIO $ startTransferInfo file
	(meter, tfile, metervar) <- mkProgressUpdater t info
	mode <- annexFileMode
	(fd, inprogress) <- liftIO $ prep tfile mode info
	if inprogress
		then do
			showNote "transfer already in progress"
			return False
		else do
			ok <- retry info metervar $
		 		bracketIO (return fd) (cleanup tfile) (const $ a meter)
			unless ok $ recordFailedTransfer t info
			return ok
  where
#ifndef mingw32_HOST_OS
	prep tfile mode info = do
		mfd <- catchMaybeIO $
			openFd (transferLockFile tfile) ReadWrite (Just mode)
				defaultFileFlags { trunc = True }
		case mfd of
			Nothing -> return (Nothing, False)
			Just fd -> do
				locked <- catchMaybeIO $
					setLock fd (WriteLock, AbsoluteSeek, 0, 0)
				if isNothing locked
					then return (Nothing, True)
					else do
						void $ tryIO $ writeTransferInfoFile info tfile
						return (mfd, False)
#else
	prep tfile _mode info = do
		v <- catchMaybeIO $ lockExclusive (transferLockFile tfile)
		case v of
			Nothing -> return (Nothing, False)
			Just Nothing -> return (Nothing, True)
			Just (Just lockhandle) -> do
				void $ tryIO $ writeTransferInfoFile info tfile
				return (Just lockhandle, False)
#endif
	cleanup _ Nothing = noop
	cleanup tfile (Just lockhandle) = do
		void $ tryIO $ removeFile tfile
#ifndef mingw32_HOST_OS
		void $ tryIO $ removeFile $ transferLockFile tfile
		closeFd lockhandle
#else
		{- Windows cannot delete the lockfile until the lock
		 - is closed. So it's possible to race with another
		 - process that takes the lock before it's removed,
		 - so ignore failure to remove.
		 -}
		dropLock lockhandle
		void $ tryIO $ removeFile $ transferLockFile tfile
#endif
	retry oldinfo metervar run = do
		v <- tryAnnex run
		case v of
			Right b -> return b
			Left e -> do
				warning (show e)
				b <- getbytescomplete metervar
				let newinfo = oldinfo { bytesComplete = Just b }
				if shouldretry oldinfo newinfo
					then retry newinfo metervar run
					else return False
	getbytescomplete metervar
		| transferDirection t == Upload =
			liftIO $ readMVar metervar
		| otherwise = do
			f <- fromRepo $ gitAnnexTmpObjectLocation (transferKey t)
			liftIO $ catchDefaultIO 0 $
				fromIntegral . fileSize <$> getFileStatus f

type RetryDecider = TransferInfo -> TransferInfo -> Bool

noRetry :: RetryDecider
noRetry _ _ = False

{- Retries a transfer when it fails, as long as the failed transfer managed
 - to send some data. -}
forwardRetry :: RetryDecider
forwardRetry old new = bytesComplete old < bytesComplete new


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
 -
 - Copyright 2010-2013 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Annex.UUID (
	getUUID,
	getRepoUUID,
	getUncachedUUID,
	prepUUID,
	genUUID,
	genUUIDInNameSpace,
	gCryptNameSpace,
	removeRepoUUID,
	storeUUID,
	storeUUIDIn,
	setUUID,
) where

import Common.Annex
import qualified Git
import qualified Git.Config
import Config

import qualified Data.UUID as U
import qualified Data.UUID.V5 as U5
import System.Random
import Data.Bits.Utils

configkey :: ConfigKey
configkey = annexConfig "uuid"

{- Generates a random UUID, that does not include the MAC address. -}
genUUID :: IO UUID
genUUID = UUID . show <$> (randomIO :: IO U.UUID)

{- Generates a UUID from a given string, using a namespace.
 - Given the same namespace, the same string will always result
 - in the same UUID. -}
genUUIDInNameSpace :: U.UUID -> String -> UUID
genUUIDInNameSpace namespace = UUID . show . U5.generateNamed namespace . s2w8

{- Namespace used for UUIDs derived from git-remote-gcrypt ids. -}
gCryptNameSpace :: U.UUID
gCryptNameSpace = U5.generateNamed U5.namespaceURL $
	s2w8 "http://git-annex.branchable.com/design/gcrypt/"

{- Get current repository's UUID. -}
getUUID :: Annex UUID
getUUID = getRepoUUID =<< gitRepo

{- Looks up a repo's UUID, caching it in .git/config if it's not already. -}
getRepoUUID :: Git.Repo -> Annex UUID
getRepoUUID r = do
	c <- toUUID <$> getConfig cachekey ""
	let u = getUncachedUUID r

	if c /= u && u /= NoUUID
		then do
			updatecache u
			return u
		else return c
  where
	updatecache u = do
		g <- gitRepo
		when (g /= r) $ storeUUIDIn cachekey u
	cachekey = remoteConfig r "uuid"

removeRepoUUID :: Annex ()
removeRepoUUID = unsetConfig configkey

getUncachedUUID :: Git.Repo -> UUID
getUncachedUUID = toUUID . Git.Config.get key ""
  where
	(ConfigKey key) = configkey

{- Make sure that the repo has an annex.uuid setting. -}
prepUUID :: Annex ()
prepUUID = whenM ((==) NoUUID <$> getUUID) $
	storeUUID =<< liftIO genUUID

storeUUID :: UUID -> Annex ()
storeUUID = storeUUIDIn configkey

storeUUIDIn :: ConfigKey -> UUID -> Annex ()
storeUUIDIn configfield = setConfig configfield . fromUUID

{- Only sets the configkey in the Repo; does not change .git/config -}
setUUID :: Git.Repo -> UUID -> IO Git.Repo
setUUID r u = do
	let s = show configkey ++ "=" ++ fromUUID u
	Git.Config.store s r


code:
{- Url downloading, with git-annex user agent and configured http
 - headers and wget/curl options.
 -
 - Copyright 2013-2014 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Annex.Url (
	module U,
	withUrlOptions,
	getUrlOptions,
	getUserAgent,
) where

import Common.Annex
import qualified Annex
import Utility.Url as U
import qualified Build.SysConfig as SysConfig

defaultUserAgent :: U.UserAgent
defaultUserAgent = "git-annex/" ++ SysConfig.packageversion

getUserAgent :: Annex (Maybe U.UserAgent)
getUserAgent = Annex.getState $
	Just . fromMaybe defaultUserAgent . Annex.useragent

getUrlOptions :: Annex U.UrlOptions
getUrlOptions = U.UrlOptions
	<$> getUserAgent
	<*> headers
	<*> options
  where
	headers = do
		v <- annexHttpHeadersCommand <$> Annex.getGitConfig
		case v of
			Just cmd -> lines <$> liftIO (readProcess "sh" ["-c", cmd])
			Nothing -> annexHttpHeaders <$> Annex.getGitConfig
	options = map Param . annexWebOptions <$> Annex.getGitConfig

withUrlOptions :: (U.UrlOptions -> IO a) -> Annex a
withUrlOptions a = liftIO . a =<< getUrlOptions


code:
{- git-annex .variant files for automatic merge conflict resolution
 -
 - Copyright 2014 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Annex.VariantFile where

import Common.Annex
import Types.Key

import Data.Hash.MD5

variantMarker :: String
variantMarker = ".variant-"

mkVariant :: FilePath -> String -> FilePath
mkVariant file variant = takeDirectory file
	</> dropExtension (takeFileName file)
	++ variantMarker ++ variant
	++ takeExtension file

{- The filename to use when resolving a conflicted merge of a file,
 - that points to a key.
 -
 - Something derived from the key needs to be included in the filename,
 - but rather than exposing the whole key to the user, a very weak hash
 - is used. There is a very real, although still unlikely, chance of
 - conflicts using this hash.
 -
 - In the event that there is a conflict with the filename generated
 - for some other key, that conflict will itself be handled by the
 - conflicted merge resolution code. That case is detected, and the full
 - key is used in the filename.
 -}
variantFile :: FilePath -> Key -> FilePath
variantFile file key
	| doubleconflict = mkVariant file (key2file key)
	| otherwise = mkVariant file (shortHash $ key2file key)
  where
	doubleconflict = variantMarker `isInfixOf` file

shortHash :: String -> String
shortHash = take 4 . md5s . md5FilePath


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

{-# LANGUAGE CPP #-}

module Annex.Version where

import Common.Annex
import Config
import qualified Annex

type Version = String

supportedVersion :: Version
supportedVersion = "5"

upgradableVersions :: [Version]
#ifndef mingw32_HOST_OS
upgradableVersions = ["0", "1", "2", "4"]
#else
upgradableVersions = ["2", "3", "4"]
#endif

autoUpgradeableVersions :: [Version]
autoUpgradeableVersions = ["3", "4"]

versionField :: ConfigKey
versionField = annexConfig "version"

getVersion :: Annex (Maybe Version)
getVersion = annexVersion <$> Annex.getGitConfig

setVersion :: Version -> Annex ()
setVersion = setConfig versionField

removeVersion :: Annex ()
removeVersion = unsetConfig versionField


code:
{- metadata based branch views
 -
 - Copyright 2014 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Annex.View where

import Common.Annex
import Annex.View.ViewedFile
import Types.View
import Types.MetaData
import Annex.MetaData
import qualified Git
import qualified Git.DiffTree as DiffTree
import qualified Git.Branch
import qualified Git.LsFiles
import qualified Git.Ref
import Git.UpdateIndex
import Git.Sha
import Git.HashObject
import Git.Types
import Git.FilePath
import qualified Backend
import Annex.Index
import Annex.Link
import Annex.CatFile
import Logs.MetaData
import Logs.View
import Utility.Glob
import Utility.FileMode
import Types.Command
import Config
import CmdLine.Action

import qualified Data.Set as S
import qualified Data.Map as M
import "mtl" Control.Monad.Writer

{- Each visible ViewFilter in a view results in another level of
 - subdirectory nesting. When a file matches multiple ways, it will appear
 - in multiple subdirectories. This means there is a bit of an exponential
 - blowup with a single file appearing in a crazy number of places!
 -
 - Capping the view size to 5 is reasonable; why wants to dig
 - through 5+ levels of subdirectories to find anything?
 -}
viewTooLarge :: View -> Bool
viewTooLarge view = visibleViewSize view > 5

visibleViewSize :: View -> Int
visibleViewSize = length . filter viewVisible . viewComponents

{- Parses field=value, field!=value, tag, and !tag
 -
 - Note that the field may not be a legal metadata field name,
 - but it's let through anyway.
 - This is useful when matching on directory names with spaces,
 - which are not legal MetaFields.
 -}
parseViewParam :: String -> (MetaField, ViewFilter)
parseViewParam s = case separate (== '=') s of
	('!':tag, []) | not (null tag) ->
		( tagMetaField
		, mkExcludeValues tag
		)
	(tag, []) ->
		( tagMetaField
		, mkFilterValues tag
		)
	(field, wanted)
		| end field == "!" ->
			( mkMetaFieldUnchecked (beginning field)
			, mkExcludeValues wanted
			)
		| otherwise ->
			( mkMetaFieldUnchecked field
			, mkFilterValues wanted
			)
  where
	mkFilterValues v
		| any (`elem` v) "*?" = FilterGlob v
		| otherwise = FilterValues $ S.singleton $ toMetaValue v
	mkExcludeValues = ExcludeValues . S.singleton . toMetaValue

data ViewChange = Unchanged | Narrowing | Widening
	deriving (Ord, Eq, Show)

{- Updates a view, adding new fields to filter on (Narrowing),
 - or allowing new values in an existing field (Widening). -}
refineView :: View -> [(MetaField, ViewFilter)] -> (View, ViewChange)
refineView origview = checksize . calc Unchanged origview
  where
	calc c v [] = (v, c)
	calc c v ((f, vf):rest) =
		let (v', c') = refine v f vf
		in calc (max c c') v' rest

	refine view field vf
		| field `elem` map viewField (viewComponents view) =
			let (components', viewchanges) = runWriter $
				mapM (\c -> updateViewComponent c field vf) (viewComponents view)
			    viewchange = if field `elem` map viewField (viewComponents origview)
			    	then maximum viewchanges
				else Narrowing
			in (view { viewComponents = components' }, viewchange)
		| otherwise =
			let component = mkViewComponent field vf
			    view' = view { viewComponents = component : viewComponents view }
			in (view', Narrowing)

	checksize r@(v, _)
		| viewTooLarge v = error $ "View is too large (" ++ show (visibleViewSize v) ++ " levels of subdirectories)"
		| otherwise = r

updateViewComponent :: ViewComponent -> MetaField -> ViewFilter -> Writer [ViewChange] ViewComponent
updateViewComponent c field vf
	| viewField c == field = do
		let (newvf, viewchange) = combineViewFilter (viewFilter c) vf
		tell [viewchange]
		return $ mkViewComponent field newvf
	| otherwise = return c

{- Adds an additional filter to a view. This can only result in narrowing
 - the view. Multivalued filters are added in non-visible form. -}
filterView :: View -> [(MetaField, ViewFilter)] -> View
filterView v vs = v { viewComponents = viewComponents f' ++ viewComponents v}
  where
	f = fst $ refineView (v {viewComponents = []}) vs
	f' = f { viewComponents = map toinvisible (viewComponents f) }
	toinvisible c = c { viewVisible = False }

{- Combine old and new ViewFilters, yielding a result that matches
 - either old+new, or only new.
 -
 - If we have FilterValues and change to a FilterGlob,
 - it's always a widening change, because the glob could match other
 - values. OTOH, going the other way, it's a Narrowing change if the old
 - glob matches all the new FilterValues.
 -
 - With two globs, the old one is discarded, and the new one is used.
 - We can tell if that's a narrowing change by checking if the old
 - glob matches the new glob. For example, "*" matches "foo*",
 - so that's narrowing. While "f?o" does not match "f??", so that's
 - widening.
 -}
combineViewFilter :: ViewFilter -> ViewFilter -> (ViewFilter, ViewChange)
combineViewFilter old@(FilterValues olds) (FilterValues news)
	| combined == old = (combined, Unchanged)
	| otherwise = (combined, Widening)
  where
	combined = FilterValues (S.union olds news)
combineViewFilter old@(ExcludeValues olds) (ExcludeValues news)
	| combined == old = (combined, Unchanged)
	| otherwise = (combined, Narrowing)
  where
	combined = ExcludeValues (S.union olds news)
combineViewFilter (FilterValues _) newglob@(FilterGlob _) =
	(newglob, Widening)
combineViewFilter (FilterGlob oldglob) new@(FilterValues s)
	| all (matchGlob (compileGlob oldglob CaseInsensative) . fromMetaValue) (S.toList s) = (new, Narrowing)
	| otherwise = (new, Widening)
combineViewFilter (FilterGlob old) newglob@(FilterGlob new)
	| old == new = (newglob, Unchanged)
	| matchGlob (compileGlob old CaseInsensative) new = (newglob, Narrowing)
	| otherwise = (newglob, Widening)
combineViewFilter (FilterGlob _) new@(ExcludeValues _) = (new, Narrowing)
combineViewFilter (ExcludeValues _) new@(FilterGlob _) = (new, Widening)
combineViewFilter (FilterValues _) new@(ExcludeValues _) = (new, Narrowing)
combineViewFilter (ExcludeValues _) new@(FilterValues _) = (new, Widening)

{- Generates views for a file from a branch, based on its metadata
 - and the filename used in the branch.
 -
 - Note that a file may appear multiple times in a view, when it
 - has multiple matching values for a MetaField used in the View.
 -
 - Of course if its MetaData does not match the View, it won't appear at
 - all.
 -
 - Note that for efficiency, it's useful to partially
 - evaluate this function with the view parameter and reuse
 - the result. The globs in the view will then be compiled and memoized.
 -}
viewedFiles :: View -> MkViewedFile -> FilePath -> MetaData -> [ViewedFile]
viewedFiles view =
	let matchers = map viewComponentMatcher (viewComponents view)
	in \mkviewedfile file metadata ->
		let matches = map (\m -> m metadata) matchers
		in if any isNothing matches
			then []
			else
				let paths = pathProduct $
					map (map toViewPath) (visible matches)
				in if null paths
					then [mkviewedfile file]
					else map (</> mkviewedfile file) paths
  where
	visible = map (fromJust . snd) .
		filter (viewVisible . fst) .
		zip (viewComponents view)

{- Checks if metadata matches a ViewComponent filter, and if so
 - returns the value, or values that match. Self-memoizing on ViewComponent. -}
viewComponentMatcher :: ViewComponent -> (MetaData -> Maybe [MetaValue])
viewComponentMatcher viewcomponent = \metadata ->
	matcher (currentMetaDataValues metafield metadata)
  where
  	metafield = viewField viewcomponent
	matcher = case viewFilter viewcomponent of
		FilterValues s -> \values -> setmatches $
			S.intersection s values
		FilterGlob glob ->
			let cglob = compileGlob glob CaseInsensative
			in \values -> setmatches $
				S.filter (matchGlob cglob . fromMetaValue) values
		ExcludeValues excludes -> \values ->
			if S.null (S.intersection values excludes)
				then Just []
				else Nothing
	setmatches s
		| S.null s = Nothing
		| otherwise = Just (S.toList s)

toViewPath :: MetaValue -> FilePath
toViewPath = concatMap escapeslash . fromMetaValue
  where
	escapeslash c
		| c == '/' = [pseudoSlash]
		| c == '\\' = [pseudoBackslash]
		| c == pseudoSlash = [pseudoSlash, pseudoSlash]
		| c == pseudoBackslash = [pseudoBackslash, pseudoBackslash]
		| otherwise = [c]

fromViewPath :: FilePath -> MetaValue
fromViewPath = toMetaValue . deescapeslash []
  where
  	deescapeslash s [] = reverse s
  	deescapeslash s (c:cs)
		| c == pseudoSlash = case cs of
			(c':cs')
				| c' == pseudoSlash -> deescapeslash (pseudoSlash:s) cs'
			_ -> deescapeslash ('/':s) cs
		| c == pseudoBackslash = case cs of
			(c':cs')
				| c' == pseudoBackslash -> deescapeslash (pseudoBackslash:s) cs'
			_ -> deescapeslash ('/':s) cs
		| otherwise = deescapeslash (c:s) cs

pseudoSlash :: Char
pseudoSlash = '\8725' -- '∕' /= '/'

pseudoBackslash :: Char
pseudoBackslash = '\9586' -- '╲' /= '\'

pathProduct :: [[FilePath]] -> [FilePath]
pathProduct [] = []
pathProduct (l:ls) = foldl combinel l ls
  where
	combinel xs ys = [combine x y | x <- xs, y <- ys]

{- Extracts the metadata from a ViewedFile, based on the view that was used
 - to construct it.
 -
 - Derived metadata is excluded.
 -}
fromView :: View -> ViewedFile -> MetaData
fromView view f = MetaData $
	M.fromList (zip fields values) `M.difference` derived
  where
	visible = filter viewVisible (viewComponents view)
	fields = map viewField visible
	paths = splitDirectories (dropFileName f)
	values = map (S.singleton . fromViewPath) paths
	MetaData derived = getViewedFileMetaData f

{- Constructing a view that will match arbitrary metadata, and applying
 - it to a file yields a set of ViewedFile which all contain the same
 - MetaFields that were present in the input metadata
 - (excluding fields that are not visible). -}
prop_view_roundtrips :: FilePath -> MetaData -> Bool -> Bool
prop_view_roundtrips f metadata visible = null f || viewTooLarge view ||
	all hasfields (viewedFiles view viewedFileFromReference f metadata)
  where
	view = View (Git.Ref "master") $
		map (\(mf, mv) -> ViewComponent mf (FilterValues $ S.filter (not . null . fromMetaValue) mv) visible)
			(fromMetaData metadata)
	visiblefields = sort (map viewField $ filter viewVisible (viewComponents view))
	hasfields fv = sort (map fst (fromMetaData (fromView view fv))) == visiblefields

{- A directory foo/bar/baz/ is turned into metadata fields
 - /=foo, foo/=bar, foo/bar/=baz.
 -
 - Note that this may generate MetaFields that legalField rejects.
 - This is necessary to have a 1:1 mapping between directory names and
 - fields. So this MetaData cannot safely be serialized. -}
getDirMetaData :: FilePath -> MetaData
getDirMetaData d = MetaData $ M.fromList $ zip fields values
  where
	dirs = splitDirectories d
	fields = map (mkMetaFieldUnchecked . addTrailingPathSeparator . joinPath)
		(inits dirs)
	values = map (S.singleton . toMetaValue . fromMaybe "" . headMaybe)
		(tails dirs)

getWorkTreeMetaData :: FilePath -> MetaData
getWorkTreeMetaData = getDirMetaData . dropFileName

getViewedFileMetaData :: FilePath -> MetaData
getViewedFileMetaData = getDirMetaData . dirFromViewedFile . takeFileName

{- Applies a view to the currently checked out branch, generating a new
 - branch for the view.
 -}
applyView :: View -> Annex Git.Branch
applyView view = applyView' viewedFileFromReference getWorkTreeMetaData view

{- Generates a new branch for a View, which must be a more narrow
 - version of the View originally used to generate the currently
 - checked out branch. That is, it must match a subset of the files
 - in view, not any others.
 -}
narrowView :: View -> Annex Git.Branch
narrowView = applyView' viewedFileReuse getViewedFileMetaData

{- Go through each file in the currently checked out branch.
 - If the file is not annexed, skip it, unless it's a dotfile in the top.
 - Look up the metadata of annexed files, and generate any ViewedFiles,
 - and stage them.
 -
 - Currently only works in indirect mode. Must be run from top of
 - repository.
 -}
applyView' :: MkViewedFile -> (FilePath -> MetaData) -> View -> Annex Git.Branch
applyView' mkviewedfile getfilemetadata view = do
	top <- fromRepo Git.repoPath
	(l, clean) <- inRepo $ Git.LsFiles.inRepo [top]
	liftIO . nukeFile =<< fromRepo gitAnnexViewIndex
	genViewBranch view $ do
		uh <- inRepo Git.UpdateIndex.startUpdateIndex
		hasher <- inRepo hashObjectStart
		forM_ l $ \f ->
			go uh hasher f =<< Backend.lookupFile f
		liftIO $ do
			hashObjectStop hasher
			void $ stopUpdateIndex uh
			void clean
  where
	genviewedfiles = viewedFiles view mkviewedfile -- enables memoization
	go uh hasher f (Just k) = do
		metadata <- getCurrentMetaData k
		let metadata' = getfilemetadata f `unionMetaData` metadata
		forM_ (genviewedfiles f metadata') $ \fv -> do
			stagesymlink uh hasher fv =<< inRepo (gitAnnexLink fv k)
	go uh hasher f Nothing
		| "." `isPrefixOf` f = do
			s <- liftIO $ getSymbolicLinkStatus f
			if isSymbolicLink s
				then stagesymlink uh hasher f =<< liftIO (readSymbolicLink f)
				else do
					sha <- liftIO $ Git.HashObject.hashFile hasher f
					let blobtype = if isExecutable (fileMode s)
						then ExecutableBlob
						else FileBlob
					liftIO . Git.UpdateIndex.streamUpdateIndex' uh
						=<< inRepo (Git.UpdateIndex.stageFile sha blobtype f)
		| otherwise = noop
	stagesymlink uh hasher f linktarget = do
		sha <- hashSymlink' hasher linktarget
		liftIO . Git.UpdateIndex.streamUpdateIndex' uh
			=<< inRepo (Git.UpdateIndex.stageSymlink f sha)

{- Applies a view to the reference branch, generating a new branch
 - for the View.
 -
 - This needs to work incrementally, to quickly update the view branch
 - when the reference branch is changed. So, it works based on an
 - old version of the reference branch, uses diffTree to find the
 - changes, and applies those changes to the view branch.
 -}
updateView :: View -> Git.Ref -> Git.Ref -> Annex Git.Branch
updateView view ref oldref = genViewBranch view $ do
	(diffs, cleanup) <- inRepo $ DiffTree.diffTree oldref ref
	forM_ diffs go
	void $ liftIO cleanup
  where
	go diff
		| DiffTree.dstsha diff == nullSha = error "TODO delete file"
		| otherwise = error "TODO add file"

{- Diff between currently checked out branch and staged changes, and
 - update metadata to reflect the changes that are being committed to the
 - view.
 -
 - Adding a file to a directory adds the metadata represented by
 - that directory to the file, and removing a file from a directory
 - removes the metadata.
 -
 - Note that removes must be handled before adds. This is so
 - that moving a file from x/foo/ to x/bar/ adds back the metadata for x.
 -}
withViewChanges :: (ViewedFile -> Key -> CommandStart) -> (ViewedFile -> Key -> CommandStart) -> Annex ()
withViewChanges addmeta removemeta = do
	makeabs <- flip fromTopFilePath <$> gitRepo
	(diffs, cleanup) <- inRepo $ DiffTree.diffIndex Git.Ref.headRef
	forM_ diffs handleremovals
	forM_ diffs (handleadds makeabs)
	void $ liftIO cleanup
  where
	handleremovals item
		| DiffTree.srcsha item /= nullSha =
			handle item removemeta
				=<< catKey (DiffTree.srcsha item) (DiffTree.srcmode item)
		| otherwise = noop
	handleadds makeabs item
		| DiffTree.dstsha item /= nullSha =
			handle item addmeta
				=<< ifM isDirect
					( catKey (DiffTree.dstsha item) (DiffTree.dstmode item)
					-- optimisation
					, isAnnexLink $ makeabs $ DiffTree.file item
					)
		| otherwise = noop
	handle item a = maybe noop
		(void . commandAction . a (getTopFilePath $ DiffTree.file item))

{- Generates a branch for a view. This is done using a different index
 - file. An action is run to stage the files that will be in the branch.
 - Then a commit is made, to the view branch. The view branch is not
 - checked out, but entering it will display the view. -}
genViewBranch :: View -> Annex () -> Annex Git.Branch
genViewBranch view a = withIndex $ do
	a
	let branch = branchView view
	void $ inRepo $ Git.Branch.commit Git.Branch.AutomaticCommit True (fromRef branch) branch []
	return branch

{- Runs an action using the view index file.
 - Note that the file does not necessarily exist, or can contain
 - info staged for an old view. -}
withIndex :: Annex a -> Annex a
withIndex a = do
	f <- fromRepo gitAnnexViewIndex
	withIndexFile f a

withCurrentView :: (View -> Annex a) -> Annex a
withCurrentView a = maybe (error "Not in a view.") a =<< currentView


code:
{- filenames (not paths) used in views
 -
 - Copyright 2014 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Annex.View.ViewedFile (
	ViewedFile,
	MkViewedFile,
	viewedFileFromReference,
	viewedFileReuse,
	dirFromViewedFile,
	prop_viewedFile_roundtrips,
) where

import Common.Annex

type FileName = String
type ViewedFile = FileName

type MkViewedFile = FilePath -> ViewedFile

{- Converts a filepath used in a reference branch to the
 - filename that will be used in the view.
 -
 - No two filepaths from the same branch should yeild the same result,
 - so all directory structure needs to be included in the output filename
 - in some way.
 -
 - So, from dir/subdir/file.foo, generate file_%dir%subdir%.foo
 -}
viewedFileFromReference :: MkViewedFile
viewedFileFromReference f = concat
	[ escape base
	, if null dirs then "" else "_%" ++ intercalate "%" (map escape dirs) ++ "%"
	, escape $ concat extensions
	]
  where
	(path, basefile) = splitFileName f
	dirs = filter (/= ".") $ map dropTrailingPathSeparator (splitPath path)
	(base, extensions) = splitShortExtensions basefile

	{- To avoid collisions with filenames or directories that contain
	 - '%', and to allow the original directories to be extracted
	 - from the ViewedFile, '%' is escaped to '\%' (and '\' to '\\').
	 -}
	escape :: String -> String
	escape = replace "%" "\\%" . replace "\\" "\\\\"

{- For use when operating already within a view, so whatever filepath
 - is present in the work tree is already a ViewedFile. -}
viewedFileReuse :: MkViewedFile
viewedFileReuse = takeFileName

{- Extracts from a ViewedFile the directory where the file is located on
 - in the reference branch. -}
dirFromViewedFile :: ViewedFile -> FilePath
dirFromViewedFile = joinPath . drop 1 . sep [] ""
  where
  	sep l _ [] = reverse l
	sep l curr (c:cs)
		| c == '%' = sep (reverse curr:l) "" cs
		| c == '\\' = case cs of
			(c':cs') -> sep l (c':curr) cs'
			[] -> sep l curr cs
		| otherwise = sep l (c:curr) cs

prop_viewedFile_roundtrips :: FilePath -> Bool
prop_viewedFile_roundtrips f
	-- Relative filenames wanted, not directories.
	| any (isPathSeparator) (end f ++ beginning f) = True
	| otherwise = dir == dirFromViewedFile (viewedFileFromReference f)
  where
	dir = joinPath $ beginning $ splitDirectories f


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

module Annex.Wanted where

import Common.Annex
import Logs.PreferredContent
import Annex.UUID

import qualified Data.Set as S

{- Check if a file is preferred content for the local repository. -}
wantGet :: Bool -> Maybe Key -> AssociatedFile -> Annex Bool
wantGet def key file = isPreferredContent Nothing S.empty key file def

{- Check if a file is preferred content for a remote. -}
wantSend :: Bool -> Maybe Key -> AssociatedFile -> UUID -> Annex Bool
wantSend def key file to = isPreferredContent (Just to) S.empty key file def

{- Check if a file can be dropped, maybe from a remote.
 - Don't drop files that are preferred content. -}
wantDrop :: Bool -> Maybe UUID -> Maybe Key -> AssociatedFile -> Annex Bool
wantDrop def from key file = do
	u <- maybe getUUID (return . id) from
	not <$> isPreferredContent (Just u) (S.singleton u) key file def


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

{-# LANGUAGE CPP #-}

module Assistant where

import qualified Annex
import Assistant.Common
import Assistant.DaemonStatus
import Assistant.NamedThread
import Assistant.Types.ThreadedMonad
import Assistant.Threads.DaemonStatus
import Assistant.Threads.Watcher
import Assistant.Threads.Committer
import Assistant.Threads.Pusher
import Assistant.Threads.Merger
import Assistant.Threads.TransferWatcher
import Assistant.Threads.Transferrer
import Assistant.Threads.RemoteControl
import Assistant.Threads.SanityChecker
import Assistant.Threads.Cronner
import Assistant.Threads.ProblemFixer
#ifdef WITH_CLIBS
import Assistant.Threads.MountWatcher
#endif
import Assistant.Threads.NetWatcher
import Assistant.Threads.Upgrader
import Assistant.Threads.UpgradeWatcher
import Assistant.Threads.TransferScanner
import Assistant.Threads.TransferPoller
import Assistant.Threads.ConfigMonitor
import Assistant.Threads.Glacier
#ifdef WITH_WEBAPP
import Assistant.WebApp
import Assistant.Threads.WebApp
#ifdef WITH_PAIRING
import Assistant.Threads.PairListener
#endif
#ifdef WITH_XMPP
import Assistant.Threads.XMPPClient
import Assistant.Threads.XMPPPusher
#endif
#else
import Assistant.Types.UrlRenderer
#endif
import qualified Utility.Daemon
import Utility.ThreadScheduler
import Utility.HumanTime
import qualified Build.SysConfig as SysConfig
import Annex.Perms
import Utility.LogFile
#ifdef mingw32_HOST_OS
import Utility.Env
import Config.Files
import System.Environment (getArgs)
#endif

import System.Log.Logger
import Network.Socket (HostName)

stopDaemon :: Annex ()
stopDaemon = liftIO . Utility.Daemon.stopDaemon =<< fromRepo gitAnnexPidFile

{- Starts the daemon. If the daemon is run in the foreground, once it's
 - running, can start the browser.
 -
 - startbrowser is passed the url and html shim file, as well as the original
 - stdout and stderr descriptors. -}
startDaemon :: Bool -> Bool -> Maybe Duration -> Maybe String -> Maybe HostName ->  Maybe (Maybe Handle -> Maybe Handle -> String -> FilePath -> IO ()) -> Annex ()
startDaemon assistant foreground startdelay cannotrun listenhost startbrowser = do
	Annex.changeState $ \s -> s { Annex.daemon = True }
	pidfile <- fromRepo gitAnnexPidFile
	logfile <- fromRepo gitAnnexLogFile
	liftIO $ debugM desc $ "logging to " ++ logfile
#ifndef mingw32_HOST_OS
	createAnnexDirectory (parentDir logfile)
	logfd <- liftIO $ handleToFd =<< openLog logfile
	if foreground
		then do
			origout <- liftIO $ catchMaybeIO $
				fdToHandle =<< dup stdOutput
			origerr <- liftIO $ catchMaybeIO $
				fdToHandle =<< dup stdError
			let undaemonize = Utility.Daemon.foreground logfd (Just pidfile)
			start undaemonize $
				case startbrowser of
					Nothing -> Nothing
					Just a -> Just $ a origout origerr
		else
			start (Utility.Daemon.daemonize logfd (Just pidfile) False) Nothing
#else
	-- Windows doesn't daemonize, but does redirect output to the
	-- log file. The only way to do so is to restart the program.
	when (foreground || not foreground) $ do
		let flag = "GIT_ANNEX_OUTPUT_REDIR"
		createAnnexDirectory (parentDir logfile)
		ifM (liftIO $ isNothing <$> getEnv flag)
			( liftIO $ withFile devNull WriteMode $ \nullh -> do
				loghandle <- openLog logfile
				e <- getEnvironment
				cmd <- readProgramFile
				ps <- getArgs
				(_, _, _, pid) <- createProcess (proc cmd ps)
					{ env = Just (addEntry flag "1" e)
					, std_in = UseHandle nullh
					, std_out = UseHandle loghandle
					, std_err = UseHandle loghandle
					}
				exitWith =<< waitForProcess pid
			, start (Utility.Daemon.foreground (Just pidfile)) $
				case startbrowser of
					Nothing -> Nothing
					Just a -> Just $ a Nothing Nothing
			)
#endif
  where
  	desc
		| assistant = "assistant"
		| otherwise = "watch"
	start daemonize webappwaiter = withThreadState $ \st -> do
		checkCanWatch
		dstatus <- startDaemonStatus
		logfile <- fromRepo gitAnnexLogFile
		liftIO $ debugM desc $ "logging to " ++ logfile
		liftIO $ daemonize $
			flip runAssistant (go webappwaiter)
				=<< newAssistantData st dstatus

#ifdef WITH_WEBAPP
	go webappwaiter = do
		d <- getAssistant id
#else
	go _webappwaiter = do
#endif
		notice ["starting", desc, "version", SysConfig.packageversion]
		urlrenderer <- liftIO newUrlRenderer
#ifdef WITH_WEBAPP
		let webappthread = [ assist $ webAppThread d urlrenderer False cannotrun Nothing listenhost webappwaiter ]
#else
		let webappthread = []
#endif
		let threads = if isJust cannotrun
			then webappthread
			else webappthread ++
				[ watch $ commitThread
#ifdef WITH_WEBAPP
#ifdef WITH_PAIRING
				, assist $ pairListenerThread urlrenderer
#endif
#ifdef WITH_XMPP
				, assist $ xmppClientThread urlrenderer
				, assist $ xmppSendPackThread urlrenderer
				, assist $ xmppReceivePackThread urlrenderer
#endif
#endif
				, assist $ pushThread
				, assist $ pushRetryThread
				, assist $ mergeThread
				, assist $ transferWatcherThread
				, assist $ transferPollerThread
				, assist $ transfererThread
				, assist $ remoteControlThread
				, assist $ daemonStatusThread
				, assist $ sanityCheckerDailyThread urlrenderer
				, assist $ sanityCheckerHourlyThread
				, assist $ problemFixerThread urlrenderer
#ifdef WITH_CLIBS
				, assist $ mountWatcherThread urlrenderer
#endif
				, assist $ netWatcherThread
				, assist $ upgraderThread urlrenderer
				, assist $ upgradeWatcherThread urlrenderer
				, assist $ netWatcherFallbackThread
				, assist $ transferScannerThread urlrenderer
				, assist $ cronnerThread urlrenderer
				, assist $ configMonitorThread
				, assist $ glacierThread
				, watch $ watchThread
				-- must come last so that all threads that wait
				-- on it have already started waiting
				, watch $ sanityCheckerStartupThread startdelay
				]

		mapM_ (startthread urlrenderer) threads
		liftIO waitForTermination

	watch a = (True, a)
	assist a = (False, a)
	startthread urlrenderer (watcher, t)
		| watcher || assistant = startNamedThread urlrenderer t
		| otherwise = noop


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

{-# LANGUAGE OverloadedStrings, CPP, BangPatterns #-}

module Assistant.Alert where

import Common.Annex
import Assistant.Types.Alert
import Assistant.Alert.Utility
import qualified Remote
import Utility.Tense
import Logs.Transfer
import Types.Distribution
import Git.Types (RemoteName)

import Data.String
import qualified Data.Text as T
import qualified Control.Exception as E

#ifdef WITH_WEBAPP
import Assistant.DaemonStatus
import Assistant.WebApp.Types
import Assistant.WebApp (renderUrl)
import Yesod
#endif
import Assistant.Monad
import Assistant.Types.UrlRenderer

{- Makes a button for an alert that opens a Route.
 -
 - If autoclose is set, the button will close the alert it's
 - attached to when clicked. -}
#ifdef WITH_WEBAPP
mkAlertButton :: Bool -> T.Text -> UrlRenderer -> Route WebApp -> Assistant AlertButton
mkAlertButton autoclose label urlrenderer route = do
	close <- asIO1 removeAlert
	url <- liftIO $ renderUrl urlrenderer route []
	return $ AlertButton
		{ buttonLabel = label
		, buttonUrl = url
		, buttonAction = if autoclose then Just close else Nothing
		, buttonPrimary = True
		}
#endif

renderData :: Alert -> TenseText
renderData = tenseWords . alertData

baseActivityAlert :: Alert
baseActivityAlert = Alert
	{ alertClass = Activity
	, alertHeader = Nothing
	, alertMessageRender = renderData
	, alertData = []
	, alertCounter = 0
	, alertBlockDisplay = False
	, alertClosable = False
	, alertPriority = Medium
	, alertIcon = Just ActivityIcon
	, alertCombiner = Nothing
	, alertName = Nothing
	, alertButtons = []
	}

warningAlert :: String -> String -> Alert
warningAlert name msg = Alert
	{ alertClass = Warning
	, alertHeader = Just $ tenseWords ["warning"]
	, alertMessageRender = renderData
	, alertData = [UnTensed $ T.pack msg]
	, alertCounter = 0
	, alertBlockDisplay = True
	, alertClosable = True
	, alertPriority = High
	, alertIcon = Just ErrorIcon
	, alertCombiner = Just $ dataCombiner $ \_old new -> new
	, alertName = Just $ WarningAlert name
	, alertButtons = []
	}

errorAlert :: String -> [AlertButton] -> Alert
errorAlert msg buttons = Alert
	{ alertClass = Error
	, alertHeader = Nothing
	, alertMessageRender = renderData
	, alertData = [UnTensed $ T.pack msg]
	, alertCounter = 0
	, alertBlockDisplay = True
	, alertClosable = True
	, alertPriority = Pinned
	, alertIcon = Just ErrorIcon
	, alertCombiner = Nothing
	, alertName = Nothing
	, alertButtons = buttons
	}

activityAlert :: Maybe TenseText -> [TenseChunk] -> Alert
activityAlert header dat = baseActivityAlert
	{ alertHeader = header
	, alertData = dat
	}

startupScanAlert :: Alert
startupScanAlert = activityAlert Nothing
	[Tensed "Performing" "Performed", "startup scan"]

{- Displayed when a shutdown is occurring, so will be seen after shutdown
 - has happened. -}
shutdownAlert :: Alert
shutdownAlert = warningAlert "shutdown" "git-annex has been shut down"

commitAlert :: Alert
commitAlert = activityAlert Nothing
	[Tensed "Committing" "Committed", "changes to git"]

showRemotes :: [RemoteName] -> TenseChunk
showRemotes = UnTensed . T.intercalate ", " . map T.pack

syncAlert :: [Remote] -> Alert
syncAlert = syncAlert' . map Remote.name

syncAlert' :: [RemoteName] -> Alert
syncAlert' rs = baseActivityAlert
	{ alertName = Just SyncAlert
	, alertHeader = Just $ tenseWords
		[Tensed "Syncing" "Synced", "with", showRemotes rs]
	, alertPriority = Low
	, alertIcon = Just SyncIcon
	}

syncResultAlert :: [Remote] -> [Remote] -> Alert
syncResultAlert succeeded failed = syncResultAlert'
	(map Remote.name succeeded)
	(map Remote.name failed)

syncResultAlert' :: [RemoteName] -> [RemoteName] -> Alert
syncResultAlert' succeeded failed = makeAlertFiller (not $ null succeeded) $
	baseActivityAlert
		{ alertName = Just SyncAlert
		, alertHeader = Just $ tenseWords msg
		}
  where
  	msg
		| null succeeded = ["Failed to sync with", showRemotes failed]
		| null failed = ["Synced with", showRemotes succeeded]
		| otherwise =
			[ "Synced with", showRemotes succeeded
			, "but not with", showRemotes failed
			]

sanityCheckAlert :: Alert
sanityCheckAlert = activityAlert
	(Just $ tenseWords [Tensed "Running" "Ran", "daily sanity check"])
	["to make sure everything is ok."]

sanityCheckFixAlert :: String -> Alert
sanityCheckFixAlert msg = Alert
	{ alertClass = Warning
	, alertHeader = Just $ tenseWords ["Fixed a problem"]
	, alertMessageRender = render
	, alertData = [UnTensed $ T.pack msg]
	, alertCounter = 0
	, alertBlockDisplay = True
	, alertPriority = High
	, alertClosable = True
	, alertIcon = Just ErrorIcon
	, alertName = Just SanityCheckFixAlert
	, alertCombiner = Just $ dataCombiner (++)
	, alertButtons = []
	}
  where
	render alert = tenseWords $ alerthead : alertData alert ++ [alertfoot]
	alerthead = "The daily sanity check found and fixed a problem:"
	alertfoot = "If these problems persist, consider filing a bug report."

fsckingAlert :: AlertButton -> Maybe Remote -> Alert
fsckingAlert button mr = baseActivityAlert
	{ alertData = case mr of
		Nothing -> [ UnTensed $ T.pack $ "Consistency check in progress" ]
		Just r -> [ UnTensed $ T.pack $ "Consistency check of " ++ Remote.name r ++ " in progress"]
	, alertButtons = [button]
	}

showFscking :: UrlRenderer -> Maybe Remote -> IO (Either E.SomeException a) -> Assistant a
showFscking urlrenderer mr a = do
#ifdef WITH_WEBAPP
	button <- mkAlertButton False (T.pack "Configure") urlrenderer ConfigFsckR
	r <- alertDuring (fsckingAlert button mr) $
		liftIO a
#else
	r <- liftIO a
#endif
	either (liftIO . E.throwIO) return r

notFsckedNudge :: UrlRenderer -> Maybe Remote -> Assistant ()
#ifdef WITH_WEBAPP
notFsckedNudge urlrenderer mr = do
	button <- mkAlertButton True (T.pack "Configure") urlrenderer ConfigFsckR
	void $ addAlert (notFsckedAlert mr button)
#else
notFsckedNudge _ _ = noop
#endif

notFsckedAlert :: Maybe Remote -> AlertButton -> Alert
notFsckedAlert mr button = Alert
	{ alertHeader = Just $ fromString $ concat
		[ "You should enable consistency checking to protect your data"
		, maybe "" (\r -> " in " ++ Remote.name r) mr
		, "."
		]
	, alertIcon = Just InfoIcon
	, alertPriority = High
	, alertButtons = [button]
	, alertClosable = True
	, alertClass = Message
	, alertMessageRender = renderData
	, alertCounter = 0
	, alertBlockDisplay = True
	, alertName = Just NotFsckedAlert
	, alertCombiner = Just $ dataCombiner $ \_old new -> new
	, alertData = []
	}

baseUpgradeAlert :: [AlertButton] -> TenseText -> Alert
baseUpgradeAlert buttons message = Alert
	{ alertHeader = Just message
	, alertIcon = Just UpgradeIcon
	, alertPriority = High
	, alertButtons = buttons
	, alertClosable = True
	, alertClass = Message
	, alertMessageRender = renderData
	, alertCounter = 0
	, alertBlockDisplay = True
	, alertName = Just UpgradeAlert
	, alertCombiner = Just $ fullCombiner $ \new _old -> new
	, alertData = []
	}

canUpgradeAlert :: AlertPriority -> GitAnnexVersion -> AlertButton -> Alert
canUpgradeAlert priority version button =
	(baseUpgradeAlert [button] $ fromString msg)
		{ alertPriority = priority
		, alertData = [fromString $ " (version " ++ version ++ ")"]
		}
  where
	msg = if priority >= High
		then "An important upgrade of git-annex is available!"
		else "An upgrade of git-annex is available."

upgradeReadyAlert :: AlertButton -> Alert
upgradeReadyAlert button = baseUpgradeAlert [button] $
	fromString "A new version of git-annex has been installed."

upgradingAlert :: Alert
upgradingAlert = activityAlert Nothing [ fromString "Upgrading git-annex" ]

upgradeFinishedAlert :: Maybe AlertButton -> GitAnnexVersion -> Alert
upgradeFinishedAlert button version =
	baseUpgradeAlert (maybeToList button) $ fromString $
		"Finished upgrading git-annex to version " ++ version

upgradeFailedAlert :: String -> Alert
upgradeFailedAlert msg = (errorAlert msg [])
	{ alertHeader = Just $ fromString "Upgrade failed." }

unusedFilesAlert :: [AlertButton] -> String -> Alert
unusedFilesAlert buttons message = Alert
	{ alertHeader = Just $ fromString $ unwords
		[ "Old and deleted files are piling up --"
		, message
		]
	, alertIcon = Just InfoIcon
	, alertPriority = High
	, alertButtons = buttons
	, alertClosable = True
	, alertClass = Message
	, alertMessageRender = renderData
	, alertCounter = 0
	, alertBlockDisplay = True
	, alertName = Just UnusedFilesAlert
	, alertCombiner = Just $ fullCombiner $ \new _old -> new
	, alertData = []
	}

brokenRepositoryAlert :: [AlertButton] -> Alert
brokenRepositoryAlert = errorAlert "Serious problems have been detected with your repository. This needs your immediate attention!"

repairingAlert :: String -> Alert
repairingAlert repodesc = activityAlert Nothing
	[ Tensed "Attempting to repair" "Repaired"
	, UnTensed $ T.pack repodesc
	]

pairingAlert :: AlertButton -> Alert
pairingAlert button = baseActivityAlert
	{ alertData = [ UnTensed "Pairing in progress" ]
	, alertPriority = High
	, alertButtons = [button]
	}

pairRequestReceivedAlert :: String -> AlertButton -> Alert
pairRequestReceivedAlert who button = Alert
	{ alertClass = Message
	, alertHeader = Nothing
	, alertMessageRender = renderData
	, alertData = [UnTensed $ T.pack $ who ++ " is sending a pair request."]
	, alertCounter = 0
	, alertBlockDisplay = False
	, alertPriority = High
	, alertClosable = True
	, alertIcon = Just InfoIcon
	, alertName = Just $ PairAlert who
	, alertCombiner = Just $ dataCombiner $ \_old new -> new
	, alertButtons = [button]
	}

pairRequestAcknowledgedAlert :: String -> Maybe AlertButton -> Alert
pairRequestAcknowledgedAlert who button = baseActivityAlert
	{ alertData = ["Pairing with", UnTensed (T.pack who), Tensed "in progress" "complete"]
	, alertPriority = High
	, alertName = Just $ PairAlert who
	, alertCombiner = Just $ dataCombiner $ \_old new -> new
	, alertButtons = maybeToList button
	}

connectionNeededAlert :: AlertButton -> Alert
connectionNeededAlert button = Alert
	{ alertHeader = Just "Share with friends, and keep your devices in sync across the cloud."
	, alertIcon = Just ConnectionIcon
	, alertPriority = High
	, alertButtons = [button]
	, alertClosable = True
	, alertClass = Message
	, alertMessageRender = renderData
	, alertCounter = 0
	, alertBlockDisplay = True
	, alertName = Just ConnectionNeededAlert
	, alertCombiner = Just $ dataCombiner $ \_old new -> new
	, alertData = []
	}

cloudRepoNeededAlert :: Maybe String -> AlertButton -> Alert
cloudRepoNeededAlert friendname button = Alert
	{ alertHeader = Just $ fromString $ unwords
		[ "Unable to download files from"
		, (fromMaybe "your other devices" friendname) ++ "."
		]
	, alertIcon = Just ErrorIcon
	, alertPriority = High
	, alertButtons = [button]
	, alertClosable = True
	, alertClass = Message
	, alertMessageRender = renderData
	, alertCounter = 0
	, alertBlockDisplay = True
	, alertName = Just $ CloudRepoNeededAlert
	, alertCombiner = Just $ dataCombiner $ \_old new -> new
	, alertData = []
	}

remoteRemovalAlert :: String -> AlertButton -> Alert
remoteRemovalAlert desc button = Alert
	{ alertHeader = Just $ fromString $
		"The repository \"" ++ desc ++
		"\" has been emptied, and can now be removed."
	, alertIcon = Just InfoIcon
	, alertPriority = High
	, alertButtons = [button]
	, alertClosable = True
	, alertClass = Message
	, alertMessageRender = renderData
	, alertCounter = 0
	, alertBlockDisplay = True
	, alertName = Just $ RemoteRemovalAlert desc
	, alertCombiner = Just $ dataCombiner $ \_old new -> new
	, alertData = []
	}

{- Show a message that relates to a list of files.
 -
 - The most recent several files are shown, and a count of any others. -}
fileAlert :: TenseChunk -> [FilePath] -> Alert
fileAlert msg files = (activityAlert Nothing shortfiles)
	{ alertName = Just $ FileAlert msg
	, alertMessageRender = renderer
	, alertCounter = counter
	, alertCombiner = Just $ fullCombiner combiner
	}
  where
	maxfilesshown = 10

	(!somefiles, !counter) = splitcounter (dedupadjacent files)
	!shortfiles = map (fromString . shortFile . takeFileName) somefiles

	renderer alert = tenseWords $ msg : alertData alert ++ showcounter
	  where
		showcounter = case alertCounter alert of
			0 -> []
			_ -> [fromString $ "and " ++ show (alertCounter alert) ++ " other files"]

	dedupadjacent (x:y:rest)
		| x == y = dedupadjacent (y:rest)
		| otherwise = x : dedupadjacent (y:rest)
	dedupadjacent (x:[]) = [x]
	dedupadjacent [] = []

	{- Note that this ensures the counter is never 1; no need to say
	 - "1 file" when the filename could be shown. -}
	splitcounter l
		| length l <= maxfilesshown = (l, 0)
		| otherwise =
			let (keep, rest) = splitAt (maxfilesshown - 1) l
			in (keep, length rest)

	combiner new old =
		let (!fs, n) = splitcounter $
			dedupadjacent $ alertData new ++ alertData old
		    !cnt = n + alertCounter new + alertCounter old
		in old
			{ alertData = fs
			, alertCounter = cnt
			}

addFileAlert :: [FilePath] -> Alert
addFileAlert = fileAlert (Tensed "Adding" "Added")

{- This is only used as a success alert after a transfer, not during it. -}
transferFileAlert :: Direction -> Bool -> FilePath -> Alert
transferFileAlert direction True file
	| direction == Upload = fileAlert "Uploaded" [file]
	| otherwise = fileAlert "Downloaded" [file]
transferFileAlert direction False file
	| direction == Upload = fileAlert "Upload failed" [file]
	| otherwise = fileAlert "Download failed" [file]

dataCombiner :: ([TenseChunk] -> [TenseChunk] -> [TenseChunk]) -> AlertCombiner
dataCombiner combiner = fullCombiner $
	\new old -> old { alertData = alertData new `combiner` alertData old }

fullCombiner :: (Alert -> Alert -> Alert) -> AlertCombiner
fullCombiner combiner new old
	| alertClass new /= alertClass old = Nothing
	| alertName new == alertName old =
		Just $! new `combiner` old
	| otherwise = Nothing

shortFile :: FilePath -> String
shortFile f
	| len < maxlen = f
	| otherwise = take half f ++ ".." ++ drop (len - half) f
  where
	len = length f
	maxlen = 20
	half = (maxlen - 2) `div` 2


code:
{- git-annex assistant alert utilities
 -
 - Copyright 2012, 2013 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Assistant.Alert.Utility where

import Common.Annex
import Assistant.Types.Alert
import Utility.Tense

import qualified Data.Text as T
import Data.Text (Text)
import qualified Data.Map as M

{- This is as many alerts as it makes sense to display at a time.
 - A display might be smaller, or larger, the point is to not overwhelm the
 - user with a ton of alerts. -}
displayAlerts :: Int
displayAlerts = 6

{- This is not a hard maximum, but there's no point in keeping a great
 - many filler alerts in an AlertMap, so when there's more than this many,
 - they start being pruned, down toward displayAlerts. -}
maxAlerts :: Int
maxAlerts = displayAlerts * 2

type AlertPair = (AlertId, Alert)

{- The desired order is the reverse of:
 -
 - - Pinned alerts
 - - High priority alerts, newest first
 - - Medium priority Activity, newest first (mostly used for Activity)
 - - Low priority alerts, newest first
 - - Filler priorty alerts, newest first
 - - Ties are broken by the AlertClass, with Errors etc coming first.
 -}
compareAlertPairs :: AlertPair -> AlertPair -> Ordering
compareAlertPairs
	(aid, Alert { alertClass = aclass, alertPriority = aprio })
	(bid, Alert { alertClass = bclass, alertPriority = bprio })
	 = compare aprio bprio
		`mappend` compare aid bid
			`mappend` compare aclass bclass

sortAlertPairs :: [AlertPair] -> [AlertPair]
sortAlertPairs = sortBy compareAlertPairs

{- Renders an alert's header for display, if it has one. -}
renderAlertHeader :: Alert -> Maybe Text
renderAlertHeader alert = renderTense (alertTense alert) <$> alertHeader alert

{- Renders an alert's message for display. -}
renderAlertMessage :: Alert -> Text
renderAlertMessage alert = renderTense (alertTense alert) $
	(alertMessageRender alert) alert

showAlert :: Alert -> String
showAlert alert = T.unpack $ T.unwords $ catMaybes
	[ renderAlertHeader alert
	, Just $ renderAlertMessage alert
	]

alertTense :: Alert -> Tense
alertTense alert
	| alertClass alert == Activity = Present
	| otherwise = Past

{- Checks if two alerts display the same. -}
effectivelySameAlert :: Alert -> Alert -> Bool
effectivelySameAlert x y = all id
	[ alertClass x == alertClass y
	, alertHeader x == alertHeader y
	, alertData x == alertData y
	, alertBlockDisplay x == alertBlockDisplay y
	, alertClosable x == alertClosable y
	, alertPriority x == alertPriority y
	]

makeAlertFiller :: Bool -> Alert -> Alert
makeAlertFiller success alert
	| isFiller alert = alert
	| otherwise = alert
		{ alertClass = if c == Activity then c' else c
		, alertPriority = Filler
		, alertClosable = True
		, alertButtons = []
		, alertIcon = Just $ if success then SuccessIcon else ErrorIcon
		}
  where
	c = alertClass alert
	c'
		| success = Success
		| otherwise = Error

isFiller :: Alert -> Bool
isFiller alert = alertPriority alert == Filler

{- Updates the Alertmap, adding or updating an alert.
 -
 - Any old filler that looks the same as the alert is removed.
 -
 - Or, if the alert has an alertCombiner that combines it with
 - an old alert, the old alert is replaced with the result, and the
 - alert is removed.
 -
 - Old filler alerts are pruned once maxAlerts is reached.
 -}
mergeAlert :: AlertId -> Alert -> AlertMap -> AlertMap
mergeAlert i al m = maybe updatePrune updateCombine (alertCombiner al)
  where
	pruneSame k al' = k == i || not (effectivelySameAlert al al')
	pruneBloat m'
		| bloat > 0 = M.fromList $ pruneold $ M.toList m'
		| otherwise = m'
	  where
		bloat = M.size m' - maxAlerts
		pruneold l =
	 		let (f, rest) = partition (\(_, a) -> isFiller a) l
			in drop bloat f ++ rest
	updatePrune = pruneBloat $ M.filterWithKey pruneSame $
		M.insertWith' const i al m
	updateCombine combiner =
		let combined = M.mapMaybe (combiner al) m
		in if M.null combined
			then updatePrune
			else M.delete i $ M.union combined m


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

module Assistant.BranchChange where

import Assistant.Common
import Assistant.Types.BranchChange

import Control.Concurrent.MSampleVar

branchChanged :: Assistant ()
branchChanged = flip writeSV () <<~ (fromBranchChangeHandle . branchChangeHandle)

waitBranchChange :: Assistant ()
waitBranchChange = readSV <<~ (fromBranchChangeHandle . branchChangeHandle)


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

module Assistant.Changes where

import Assistant.Common
import Assistant.Types.Changes
import Utility.TList

import Data.Time.Clock
import Control.Concurrent.STM

{- Handlers call this when they made a change that needs to get committed. -}
madeChange :: FilePath -> ChangeInfo -> Assistant (Maybe Change)
madeChange f t = Just <$> (Change <$> liftIO getCurrentTime <*> pure f <*> pure t)

noChange :: Assistant (Maybe Change)
noChange = return Nothing

{- Indicates an add needs to be done, but has not started yet. -}
pendingAddChange :: FilePath -> Assistant (Maybe Change)
pendingAddChange f = Just <$> (PendingAddChange <$> liftIO getCurrentTime <*> pure f)

{- Gets all unhandled changes.
 - Blocks until at least one change is made. -}
getChanges :: Assistant [Change]
getChanges = (atomically . getTList) <<~ changePool

{- Gets all unhandled changes, without blocking. -}
getAnyChanges :: Assistant [Change]
getAnyChanges = (atomically . takeTList) <<~ changePool

{- Puts unhandled changes back into the pool.
 - Note: Original order is not preserved. -}
refillChanges :: [Change] -> Assistant ()
refillChanges cs = (atomically . flip appendTList cs) <<~ changePool

{- Records a change to the pool. -}
recordChange :: Change -> Assistant ()
recordChange c = (atomically . flip snocTList c) <<~ changePool

recordChanges :: [Change] -> Assistant ()
recordChanges = refillChanges


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

module Assistant.Commits where

import Assistant.Common
import Assistant.Types.Commits
import Utility.TList

import Control.Concurrent.STM

{- Gets all unhandled commits.
 - Blocks until at least one commit is made. -}
getCommits :: Assistant [Commit]
getCommits = (atomically . getTList) <<~ commitChan

{- Records a commit in the channel. -}
recordCommit :: Assistant ()
recordCommit = (atomically . flip consTList Commit) <<~ commitChan


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

module Assistant.Common (module X) where

import Common.Annex as X
import Assistant.Monad as X
import Assistant.Types.DaemonStatus as X
import Assistant.Types.NamedThread as X
import Assistant.Types.Alert as X


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

{-# LANGUAGE BangPatterns #-}

module Assistant.CredPairCache (
	cacheCred,
	getCachedCred,
	expireCachedCred,
) where

import Assistant.Types.CredPairCache
import Types.Creds
import Assistant.Common
import Utility.ThreadScheduler

import qualified Data.Map as M
import Control.Concurrent

{- Caches a CredPair, but only for a limited time, after which it
 - will expire.
 -
 - Note that repeatedly caching the same CredPair
 - does not reset its expiry time.
 -}
cacheCred :: CredPair -> Seconds -> Assistant ()
cacheCred (login, password) expireafter = do
	cache <- getAssistant credPairCache
	liftIO $ do
		changeStrict cache $ M.insert login password
		void $ forkIO $ do
			threadDelaySeconds expireafter
			changeStrict cache $ M.delete login

getCachedCred :: Login -> Assistant (Maybe Password)
getCachedCred login = do
	cache <- getAssistant credPairCache
	liftIO $ M.lookup login <$> readMVar cache

expireCachedCred :: Login -> Assistant ()
expireCachedCred login = do
	cache <- getAssistant credPairCache
	liftIO $ changeStrict cache $ M.delete login

{- Update map strictly to avoid keeping references to old creds in memory. -}
changeStrict :: CredPairCache -> (M.Map Login Password -> M.Map Login Password) -> IO ()
changeStrict cache a = modifyMVar_ cache $ \m -> do
	let !m' = a m
	return m'