git-annex (5.20140402) unstable; urgency=medium

* unannex, uninit: Avoid committing after every file is unannexed,
    for massive speedup.
  * --notify-finish switch will cause desktop notifications after each
    file upload/download/drop completes
    (using the dbus Desktop Notifications Specification)
  * --notify-start switch will show desktop notifications when each
    file upload/download starts.
  * webapp: Automatically install Nautilus integration scripts
    to get and drop files.
  * tahoe: Pass -d parameter before subcommand; putting it after
    the subcommand no longer works with tahoe-lafs version 1.10.
    (Thanks, Alberto Berti)
  * forget --drop-dead: Avoid removing the dead remote from the trust.log,
    so that if git remotes for it still exist anywhere, git annex info
    will still know it's dead and not show it.
  * git-annex-shell: Make configlist automatically initialize
    a remote git repository, as long as a git-annex branch has
    been pushed to it, to simplify setup of remote git repositories,
    including via gitolite.
  * add --include-dotfiles: New option, perhaps useful for backups.
  * Version 5.20140227 broke creation of glacier repositories,
    not including the datacenter and vault in their configuration.
    This bug is fixed, but glacier repositories set up with the broken
    version of git-annex need to have the datacenter and vault set
    in order to be usable. This can be done using git annex enableremote
    to add the missing settings. For details, see
    http://git-annex.branchable.com/bugs/problems_with_glacier/
  * Added required content configuration.
  * assistant: Improve ssh authorized keys line generated in local pairing
    or for a remote ssh server to set environment variables in an
    alternative way that works with the non-POSIX fish shell, as well
    as POSIX shells.

# imported from the archive

.ghci

@@ -0,0 +1 @@
+:load Common

.gitattributes

@@ -0,0 +1 @@
+debian/changelog merge=dpkg-mergechangelogs

.gitignore

@@ -0,0 +1,31 @@
+tags
+Setup
+*.hi
+*.o
+tmp
+test
+build-stamp
+Build/SysConfig.hs
+Build/InstallDesktopFile
+Build/EvilSplicer
+Build/Standalone
+Build/OSXMkLibs
+Build/LinuxMkLibs
+git-annex
+git-annex.1
+git-annex-shell.1
+git-union-merge
+git-union-merge.1
+doc/.ikiwiki
+html
+*.tix
+.hpc
+dist
+# Sandboxed builds
+cabal-dev
+# Project-local emacs configuration
+.dir-locals.el
+# OSX related
+.DS_Store
+.virthualenv
+.tasty-rerun-log

.mailmap

@@ -0,0 +1,6 @@
+Joey Hess <joey@kitenet.net> http://joey.kitenet.net/ <joey@web>
+Joey Hess <joey@kitenet.net> http://joeyh.name/ <joey@web>
+Joey Hess <joey@kitenet.net> http://joeyh.name/ <http://joeyh.name/@web>
+Yaroslav Halchenko <debian@onerussian.com>
+Yaroslav Halchenko <debian@onerussian.com> http://yarikoptic.myopenid.com/ <site-myopenid@web>
+Yaroslav Halchenko <debian@onerussian.com> https://www.google.com/accounts/o8/id?id=AItOawnx8kHW66N3BqmkVpgtXDlYMvr8TJ5VvfY <Yaroslav@web>

Annex.hs

@@ -0,0 +1,272 @@
+{- git-annex monad
+ -
+ - Copyright 2010-2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE GeneralizedNewtypeDeriving, PackageImports #-}
+
+module Annex (
+	Annex,
+	AnnexState(..),
+	new,
+	run,
+	eval,
+	getState,
+	changeState,
+	setFlag,
+	setField,
+	setOutput,
+	getFlag,
+	getField,
+	addCleanup,
+	gitRepo,
+	inRepo,
+	fromRepo,
+	calcRepo,
+	getGitConfig,
+	changeGitConfig,
+	changeGitRepo,
+	withCurrentState,
+) where
+
+import "mtl" Control.Monad.Reader
+import "MonadCatchIO-transformers" Control.Monad.CatchIO
+import Control.Concurrent
+
+import Common
+import qualified Git
+import qualified Git.Config
+import Annex.Direct.Fixup
+import Git.CatFile
+import Git.CheckAttr
+import Git.CheckIgnore
+import Git.SharedRepository
+import qualified Git.Hook
+import qualified Git.Queue
+import Types.Key
+import Types.Backend
+import Types.GitConfig
+import qualified Types.Remote
+import Types.Crypto
+import Types.BranchState
+import Types.TrustLevel
+import Types.Group
+import Types.Messages
+import Types.UUID
+import Types.FileMatcher
+import Types.NumCopies
+import Types.LockPool
+import Types.MetaData
+import Types.DesktopNotify
+import Types.CleanupActions
+import qualified Data.Map as M
+import qualified Data.Set as S
+import Utility.Quvi (QuviVersion)
+
+{- git-annex's monad is a ReaderT around an AnnexState stored in a MVar.
+ - This allows modifying the state in an exception-safe fashion.
+ - The MVar is not exposed outside this module.
+ -}
+newtype Annex a = Annex { runAnnex :: ReaderT (MVar AnnexState) IO a }
+	deriving (
+		Monad,
+		MonadIO,
+		MonadReader (MVar AnnexState),
+		MonadCatchIO,
+		Functor,
+		Applicative
+	)
+
+-- internal state storage
+data AnnexState = AnnexState
+	{ repo :: Git.Repo
+	, gitconfig :: GitConfig
+	, backends :: [BackendA Annex]
+	, remotes :: [Types.Remote.RemoteA Annex]
+	, remoteannexstate :: M.Map UUID AnnexState
+	, output :: MessageState
+	, force :: Bool
+	, fast :: Bool
+	, auto :: Bool
+	, daemon :: Bool
+	, branchstate :: BranchState
+	, repoqueue :: Maybe Git.Queue.Queue
+	, catfilehandles :: M.Map FilePath CatFileHandle
+	, checkattrhandle :: Maybe CheckAttrHandle
+	, checkignorehandle :: Maybe (Maybe CheckIgnoreHandle)
+	, forcebackend :: Maybe String
+	, globalnumcopies :: Maybe NumCopies
+	, forcenumcopies :: Maybe NumCopies
+	, limit :: ExpandableMatcher Annex
+	, uuidmap :: Maybe UUIDMap
+	, preferredcontentmap :: Maybe (FileMatcherMap Annex)
+	, requiredcontentmap :: Maybe (FileMatcherMap Annex)
+	, shared :: Maybe SharedRepository
+	, forcetrust :: TrustMap
+	, trustmap :: Maybe TrustMap
+	, groupmap :: Maybe GroupMap
+	, ciphers :: M.Map StorableCipher Cipher
+	, lockpool :: LockPool
+	, flags :: M.Map String Bool
+	, fields :: M.Map String String
+	, modmeta :: [ModMeta]
+	, cleanup :: M.Map CleanupAction (Annex ())
+	, inodeschanged :: Maybe Bool
+	, useragent :: Maybe String
+	, errcounter :: Integer
+	, unusedkeys :: Maybe (S.Set Key)
+	, quviversion :: Maybe QuviVersion
+	, existinghooks :: M.Map Git.Hook.Hook Bool
+	, desktopnotify :: DesktopNotify
+	}
+
+newState :: GitConfig -> Git.Repo -> AnnexState
+newState c r = AnnexState
+	{ repo = r
+	, gitconfig = c
+	, backends = []
+	, remotes = []
+	, remoteannexstate = M.empty
+	, output = defaultMessageState
+	, force = False
+	, fast = False
+	, auto = False
+	, daemon = False
+	, branchstate = startBranchState
+	, repoqueue = Nothing
+	, catfilehandles = M.empty
+	, checkattrhandle = Nothing
+	, checkignorehandle = Nothing
+	, forcebackend = Nothing
+	, globalnumcopies = Nothing
+	, forcenumcopies = Nothing
+	, limit = BuildingMatcher []
+	, uuidmap = Nothing
+	, preferredcontentmap = Nothing
+	, requiredcontentmap = Nothing
+	, shared = Nothing
+	, forcetrust = M.empty
+	, trustmap = Nothing
+	, groupmap = Nothing
+	, ciphers = M.empty
+	, lockpool = M.empty
+	, flags = M.empty
+	, fields = M.empty
+	, modmeta = []
+	, cleanup = M.empty
+	, inodeschanged = Nothing
+	, useragent = Nothing
+	, errcounter = 0
+	, unusedkeys = Nothing
+	, quviversion = Nothing
+	, existinghooks = M.empty
+	, desktopnotify = mempty
+	}
+
+{- Makes an Annex state object for the specified git repo.
+ - Ensures the config is read, if it was not already. -}
+new :: Git.Repo -> IO AnnexState
+new r = do
+	r' <- Git.Config.read r
+	let c = extractGitConfig r'
+	newState c <$> if annexDirect c then fixupDirect r' else return r'
+
+{- Performs an action in the Annex monad from a starting state,
+ - returning a new state. -}
+run :: AnnexState -> Annex a -> IO (a, AnnexState)
+run s a = do
+	mvar <- newMVar s
+	r <- runReaderT (runAnnex a) mvar
+	s' <- takeMVar mvar
+	return (r, s')
+
+{- Performs an action in the Annex monad from a starting state, 
+ - and throws away the new state. -}
+eval :: AnnexState -> Annex a -> IO a
+eval s a = do
+	mvar <- newMVar s
+	runReaderT (runAnnex a) mvar
+
+getState :: (AnnexState -> v) -> Annex v
+getState selector = do
+	mvar <- ask
+	s <- liftIO $ readMVar mvar
+	return $ selector s
+
+changeState :: (AnnexState -> AnnexState) -> Annex ()
+changeState modifier = do
+	mvar <- ask
+	liftIO $ modifyMVar_ mvar $ return . modifier
+
+{- Sets a flag to True -}
+setFlag :: String -> Annex ()
+setFlag flag = changeState $ \s ->
+	s { flags = M.insertWith' const flag True $ flags s }
+
+{- Sets a field to a value -}
+setField :: String -> String -> Annex ()
+setField field value = changeState $ \s ->
+	s { fields = M.insertWith' const field value $ fields s }
+
+{- Adds a cleanup action to perform. -}
+addCleanup :: CleanupAction -> Annex () -> Annex ()
+addCleanup k a = changeState $ \s ->
+	s { cleanup = M.insertWith' const k a $ cleanup s }
+
+{- Sets the type of output to emit. -}
+setOutput :: OutputType -> Annex ()
+setOutput o = changeState $ \s ->
+	s { output = (output s) { outputType = o } }
+
+{- Checks if a flag was set. -}
+getFlag :: String -> Annex Bool
+getFlag flag = fromMaybe False . M.lookup flag <$> getState flags
+
+{- Gets the value of a field. -}
+getField :: String -> Annex (Maybe String)
+getField field = M.lookup field <$> getState fields
+
+{- Returns the annex's git repository. -}
+gitRepo :: Annex Git.Repo
+gitRepo = getState repo
+
+{- Runs an IO action in the annex's git repository. -}
+inRepo :: (Git.Repo -> IO a) -> Annex a
+inRepo a = liftIO . a =<< gitRepo
+
+{- Extracts a value from the annex's git repisitory. -}
+fromRepo :: (Git.Repo -> a) -> Annex a
+fromRepo a = a <$> gitRepo
+
+{- Calculates a value from an annex's git repository and its GitConfig. -}
+calcRepo :: (Git.Repo -> GitConfig -> IO a) -> Annex a
+calcRepo a = do
+	s <- getState id
+	liftIO $ a (repo s) (gitconfig s)
+
+{- Gets the GitConfig settings. -}
+getGitConfig :: Annex GitConfig
+getGitConfig = getState gitconfig
+
+{- Modifies a GitConfig setting. -}
+changeGitConfig :: (GitConfig -> GitConfig) -> Annex ()
+changeGitConfig a = changeState $ \s -> s { gitconfig = a (gitconfig s) }
+
+{- Changing the git Repo data also involves re-extracting its GitConfig. -}
+changeGitRepo :: Git.Repo -> Annex ()
+changeGitRepo r = changeState $ \s -> s
+	{ repo = r
+	, gitconfig = extractGitConfig r
+	}
+
+{- Converts an Annex action into an IO action, that runs with a copy
+ - of the current Annex state. 
+ -
+ - Use with caution; the action should not rely on changing the
+ - state, as it will be thrown away. -}
+withCurrentState :: Annex a -> Annex (IO a)
+withCurrentState a = do
+	s <- getState id
+	return $ eval s a

Annex/AutoMerge.hs

@@ -0,0 +1,179 @@
+{- git-annex automatic merge conflict resolution
+ -
+ - Copyright 2012-2014 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Annex.AutoMerge (autoMergeFrom) where
+
+import Common.Annex
+import qualified Annex.Queue
+import Annex.Direct
+import Annex.CatFile
+import Annex.Link
+import qualified Git.Command
+import qualified Git.LsFiles as LsFiles
+import qualified Git.UpdateIndex as UpdateIndex
+import qualified Git.Merge
+import qualified Git.Ref
+import qualified Git.Sha
+import qualified Git
+import Git.Types (BlobType(..))
+import Config
+import Annex.ReplaceFile
+import Git.FileMode
+import Annex.VariantFile
+
+import qualified Data.Set as S
+
+{- Merges from a branch into the current branch
+ - (which may not exist yet),
+ - with automatic merge conflict resolution. -}
+autoMergeFrom :: Git.Ref -> (Maybe Git.Ref) -> Annex Bool
+autoMergeFrom branch currbranch = do
+	showOutput
+	case currbranch of
+		Nothing -> go Nothing
+		Just b -> go =<< inRepo (Git.Ref.sha b)
+  where
+	go old = ifM isDirect
+		( do
+			d <- fromRepo gitAnnexMergeDir
+			r <- inRepo (mergeDirect d branch)
+				<||> resolveMerge old branch
+			mergeDirectCleanup d (fromMaybe Git.Sha.emptyTree old) Git.Ref.headRef
+			return r
+		, inRepo (Git.Merge.mergeNonInteractive branch)
+			<||> resolveMerge old branch
+		)
+
+{- Resolves a conflicted merge. It's important that any conflicts be
+ - resolved in a way that itself avoids later merge conflicts, since
+ - multiple repositories may be doing this concurrently.
+ -
+ - Only merge conflicts where at least one side is an annexed file
+ - is resolved.
+ -
+ - This uses the Keys pointed to by the files to construct new
+ - filenames. So when both sides modified annexed file foo, 
+ - it will be deleted, and replaced with files foo.variant-A and
+ - foo.variant-B.
+ -
+ - On the other hand, when one side deleted foo, and the other modified it,
+ - it will be deleted, and the modified version stored as file
+ - foo.variant-A (or B).
+ -
+ - It's also possible that one side has foo as an annexed file, and
+ - the other as a directory or non-annexed file. The annexed file
+ - is renamed to resolve the merge, and the other object is preserved as-is.
+ -
+ - In indirect mode, the merge is resolved in the work tree and files
+ - staged, to clean up from a conflicted merge that was run in the work
+ - tree. In direct mode, the work tree is not touched here; files are 
+ - staged to the index, and written to the gitAnnexMergeDir, and later
+ - mergeDirectCleanup handles updating the work tree.
+ -}
+resolveMerge :: Maybe Git.Ref -> Git.Ref -> Annex Bool
+resolveMerge us them = do
+	top <- fromRepo Git.repoPath
+	(fs, cleanup) <- inRepo (LsFiles.unmerged [top])
+	mergedfs <- catMaybes <$> mapM (resolveMerge' us them) fs
+	let merged = not (null mergedfs)
+	void $ liftIO cleanup
+
+	unlessM isDirect $ do
+		(deleted, cleanup2) <- inRepo (LsFiles.deleted [top])
+		unless (null deleted) $
+			Annex.Queue.addCommand "rm" [Params "--quiet -f --"] deleted
+		void $ liftIO cleanup2
+
+	when merged $ do
+		unlessM isDirect $
+			cleanConflictCruft mergedfs top
+		Annex.Queue.flush
+		whenM isDirect $
+			void preCommitDirect
+		void $ inRepo $ Git.Command.runBool
+			[ Param "commit"
+			, Param "--no-verify"
+			, Param "-m"
+			, Param "git-annex automatic merge conflict fix"
+			]
+		showLongNote "Merge conflict was automatically resolved; you may want to examine the result."
+	return merged
+
+resolveMerge' :: Maybe Git.Ref -> Git.Ref -> LsFiles.Unmerged -> Annex (Maybe FilePath)
+resolveMerge' Nothing _ _ = return Nothing
+resolveMerge' (Just us) them u = do
+	kus <- getkey LsFiles.valUs LsFiles.valUs 
+	kthem <- getkey LsFiles.valThem LsFiles.valThem
+	case (kus, kthem) of
+		-- Both sides of conflict are annexed files
+		(Just keyUs, Just keyThem)
+			| keyUs /= keyThem -> resolveby $ do
+				makelink keyUs
+				makelink keyThem
+			| otherwise -> resolveby $
+				makelink keyUs
+		-- Our side is annexed file, other side is not.
+		(Just keyUs, Nothing) -> resolveby $ do
+			graftin them file
+			makelink keyUs
+		-- Our side is not annexed file, other side is.
+		(Nothing, Just keyThem) -> resolveby $ do
+			graftin us file
+			makelink keyThem
+		-- Neither side is annexed file; cannot resolve.
+		(Nothing, Nothing) -> return Nothing
+  where
+	file = LsFiles.unmergedFile u
+
+	getkey select select'
+		| select (LsFiles.unmergedBlobType u) == Just SymlinkBlob =
+			case select' (LsFiles.unmergedSha u) of
+				Nothing -> return Nothing
+				Just sha -> catKey sha symLinkMode
+		| otherwise = return Nothing
+	
+	makelink key = do
+		let dest = variantFile file key
+		l <- inRepo $ gitAnnexLink dest key
+		ifM isDirect
+			( do
+				d <- fromRepo gitAnnexMergeDir
+				replaceFile (d </> dest) $ makeAnnexLink l
+			, replaceFile dest $ makeAnnexLink l
+			)
+		stageSymlink dest =<< hashSymlink l
+
+	{- stage a graft of a directory or file from a branch -}
+	graftin b item = Annex.Queue.addUpdateIndex
+		=<< fromRepo (UpdateIndex.lsSubTree b item)
+		
+	resolveby a = do
+		{- Remove conflicted file from index so merge can be resolved. -}
+		Annex.Queue.addCommand "rm" [Params "--quiet -f --cached --"] [file]
+		void a
+		return (Just file)
+
+{- git-merge moves conflicting files away to files
+ - named something like f~HEAD or f~branch, but the
+ - exact name chosen can vary. Once the conflict is resolved,
+ - this cruft can be deleted. To avoid deleting legitimate
+ - files that look like this, only delete files that are
+ - A) not staged in git and B) look like git-annex symlinks.
+ -}
+cleanConflictCruft :: [FilePath] -> FilePath -> Annex ()
+cleanConflictCruft resolvedfs top = do
+	(fs, cleanup) <- inRepo $ LsFiles.notInRepo False [top]
+	mapM_ clean fs
+	void $ liftIO cleanup
+  where
+	clean f
+		| matchesresolved f = whenM (isJust <$> isAnnexLink f) $
+			liftIO $ nukeFile f
+		| otherwise = noop
+	s = S.fromList resolvedfs
+	matchesresolved f = S.member (base f) s
+	base f = reverse $ drop 1 $ dropWhile (/= '~') $ reverse f

Annex/Branch.hs

@@ -0,0 +1,516 @@
+{- management of the git-annex branch
+ -
+ - Copyright 2011-2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Annex.Branch (
+	fullname,
+	name,
+	hasOrigin,
+	hasSibling,
+	siblingBranches,
+	create,
+	update,
+	forceUpdate,
+	updateTo,
+	get,
+	getHistorical,
+	change,
+	commit,
+	forceCommit,
+	files,
+	withIndex,
+	performTransitions,
+) where
+
+import qualified Data.ByteString.Lazy.Char8 as L
+import qualified Data.Set as S
+import qualified Data.Map as M
+
+import Common.Annex
+import Annex.BranchState
+import Annex.Journal
+import Annex.Index
+import qualified Git
+import qualified Git.Command
+import qualified Git.Ref
+import qualified Git.Sha
+import qualified Git.Branch
+import qualified Git.UnionMerge
+import qualified Git.UpdateIndex
+import Git.HashObject
+import Git.Types
+import Git.FilePath
+import Annex.CatFile
+import Annex.Perms
+import Logs
+import Logs.Transitions
+import Logs.Trust.Pure
+import Annex.ReplaceFile
+import qualified Annex.Queue
+import Annex.Branch.Transitions
+
+{- Name of the branch that is used to store git-annex's information. -}
+name :: Git.Ref
+name = Git.Ref "git-annex"
+
+{- Fully qualified name of the branch. -}
+fullname :: Git.Ref
+fullname = Git.Ref $ "refs/heads/" ++ fromRef name
+
+{- Branch's name in origin. -}
+originname :: Git.Ref
+originname = Git.Ref $ "origin/" ++ fromRef name
+
+{- Does origin/git-annex exist? -}
+hasOrigin :: Annex Bool
+hasOrigin = inRepo $ Git.Ref.exists originname
+
+{- Does the git-annex branch or a sibling foo/git-annex branch exist? -}
+hasSibling :: Annex Bool
+hasSibling = not . null <$> siblingBranches
+
+{- List of git-annex (refs, branches), including the main one and any
+ - from remotes. Duplicate refs are filtered out. -}
+siblingBranches :: Annex [(Git.Ref, Git.Branch)]
+siblingBranches = inRepo $ Git.Ref.matchingUniq [name]
+
+{- Creates the branch, if it does not already exist. -}
+create :: Annex ()
+create = void getBranch
+
+{- Returns the ref of the branch, creating it first if necessary. -}
+getBranch :: Annex Git.Ref
+getBranch = maybe (hasOrigin >>= go >>= use) return =<< branchsha
+  where
+	go True = do
+		inRepo $ Git.Command.run
+			[Param "branch", Param $ fromRef name, Param $ fromRef originname]
+		fromMaybe (error $ "failed to create " ++ fromRef name)
+			<$> branchsha
+	go False = withIndex' True $
+		inRepo $ Git.Branch.commitAlways "branch created" fullname []
+	use sha = do
+		setIndexSha sha
+		return sha
+	branchsha = inRepo $ Git.Ref.sha fullname
+
+{- Ensures that the branch and index are up-to-date; should be
+ - called before data is read from it. Runs only once per git-annex run. -}
+update :: Annex ()
+update = runUpdateOnce $ void $ updateTo =<< siblingBranches
+
+{- Forces an update even if one has already been run. -}
+forceUpdate :: Annex Bool
+forceUpdate = updateTo =<< siblingBranches
+
+{- Merges the specified Refs into the index, if they have any changes not
+ - already in it. The Branch names are only used in the commit message;
+ - it's even possible that the provided Branches have not been updated to
+ - point to the Refs yet.
+ - 
+ - The branch is fast-forwarded if possible, otherwise a merge commit is
+ - made.
+ -
+ - Before Refs are merged into the index, it's important to first stage the
+ - journal into the index. Otherwise, any changes in the journal would
+ - later get staged, and might overwrite changes made during the merge.
+ - This is only done if some of the Refs do need to be merged.
+ -
+ - Also handles performing any Transitions that have not yet been
+ - performed, in either the local branch, or the Refs.
+ -
+ - Returns True if any refs were merged in, False otherwise.
+ -}
+updateTo :: [(Git.Ref, Git.Branch)] -> Annex Bool
+updateTo pairs = do
+	-- ensure branch exists, and get its current ref
+	branchref <- getBranch
+	dirty <- journalDirty
+	ignoredrefs <- getIgnoredRefs
+	(refs, branches) <- unzip <$> filterM (isnewer ignoredrefs) pairs
+	if null refs
+		{- Even when no refs need to be merged, the index
+		 - may still be updated if the branch has gotten ahead 
+		 - of the index. -}
+		then whenM (needUpdateIndex branchref) $ lockJournal $ \jl -> do
+			forceUpdateIndex jl branchref
+			{- When there are journalled changes
+			 - as well as the branch being updated,
+			 - a commit needs to be done. -}
+			when dirty $
+				go branchref True [] [] jl
+		else lockJournal $ go branchref dirty refs branches
+	return $ not $ null refs
+  where
+	isnewer ignoredrefs (r, _)
+		| S.member r ignoredrefs = return False
+		| otherwise = inRepo $ Git.Branch.changed fullname r
+	go branchref dirty refs branches jl = withIndex $ do
+		cleanjournal <- if dirty then stageJournal jl else return noop
+		let merge_desc = if null branches
+			then "update"
+			else "merging " ++
+				unwords (map Git.Ref.describe branches) ++ 
+				" into " ++ fromRef name
+		localtransitions <- parseTransitionsStrictly "local"
+			<$> getLocal transitionsLog
+		unless (null branches) $ do
+			showSideAction merge_desc
+			mergeIndex jl refs
+		let commitrefs = nub $ fullname:refs
+		unlessM (handleTransitions jl localtransitions commitrefs) $ do
+			ff <- if dirty
+				then return False
+				else inRepo $ Git.Branch.fastForward fullname refs
+			if ff
+				then updateIndex jl branchref
+				else commitIndex jl branchref merge_desc commitrefs
+		liftIO cleanjournal
+
+{- Gets the content of a file, which may be in the journal, or in the index
+ - (and committed to the branch).
+ - 
+ - Updates the branch if necessary, to ensure the most up-to-date available
+ - content is returned.
+ -
+ - Returns an empty string if the file doesn't exist yet. -}
+get :: FilePath -> Annex String
+get file = do
+	update
+	getLocal file
+
+{- Like get, but does not merge the branch, so the info returned may not
+ - reflect changes in remotes.
+ - (Changing the value this returns, and then merging is always the
+ - same as using get, and then changing its value.) -}
+getLocal :: FilePath -> Annex String
+getLocal file = go =<< getJournalFileStale file
+  where
+	go (Just journalcontent) = return journalcontent
+	go Nothing = getRaw file
+
+getRaw :: FilePath -> Annex String
+getRaw = getRef fullname
+
+getHistorical :: RefDate -> FilePath -> Annex String
+getHistorical date = getRef (Git.Ref.dateRef fullname date)
+
+getRef :: Ref -> FilePath -> Annex String
+getRef ref file = withIndex $ L.unpack <$> catFile ref file
+
+{- Applies a function to modifiy the content of a file.
+ -
+ - Note that this does not cause the branch to be merged, it only
+ - modifes the current content of the file on the branch.
+ -}
+change :: FilePath -> (String -> String) -> Annex ()
+change file a = lockJournal $ \jl -> a <$> getLocal file >>= set jl file
+
+{- Records new content of a file into the journal -}
+set :: JournalLocked -> FilePath -> String -> Annex ()
+set = setJournalFile
+
+{- Stages the journal, and commits staged changes to the branch. -}
+commit :: String -> Annex ()
+commit = whenM journalDirty . forceCommit
+
+{- Commits the current index to the branch even without any journalleda
+ - changes. -}
+forceCommit :: String -> Annex ()
+forceCommit message = lockJournal $ \jl -> do
+	cleanjournal <- stageJournal jl
+	ref <- getBranch
+	withIndex $ commitIndex jl ref message [fullname]
+	liftIO cleanjournal
+
+{- Commits the staged changes in the index to the branch.
+ - 
+ - Ensures that the branch's index file is first updated to the state
+ - of the branch at branchref, before running the commit action. This
+ - is needed because the branch may have had changes pushed to it, that
+ - are not yet reflected in the index.
+ -
+ - Also safely handles a race that can occur if a change is being pushed
+ - into the branch at the same time. When the race happens, the commit will
+ - be made on top of the newly pushed change, but without the index file
+ - being updated to include it. The result is that the newly pushed
+ - change is reverted. This race is detected and another commit made
+ - to fix it.
+ - 
+ - The branchref value can have been obtained using getBranch at any
+ - previous point, though getting it a long time ago makes the race
+ - more likely to occur.
+ -}
+commitIndex :: JournalLocked -> Git.Ref -> String -> [Git.Ref] -> Annex ()
+commitIndex jl branchref message parents = do
+	showStoringStateAction
+	commitIndex' jl branchref message parents
+commitIndex' :: JournalLocked -> Git.Ref -> String -> [Git.Ref] -> Annex ()
+commitIndex' jl branchref message parents = do
+	updateIndex jl branchref
+	committedref <- inRepo $ Git.Branch.commitAlways message fullname parents
+	setIndexSha committedref
+	parentrefs <- commitparents <$> catObject committedref
+	when (racedetected branchref parentrefs) $
+		fixrace committedref parentrefs
+  where
+	-- look for "parent ref" lines and return the refs
+	commitparents = map (Git.Ref . snd) . filter isparent .
+		map (toassoc . L.unpack) . L.lines
+	toassoc = separate (== ' ')
+	isparent (k,_) = k == "parent"
+		
+	{- The race can be detected by checking the commit's
+	 - parent, which will be the newly pushed branch,
+	 - instead of the expected ref that the index was updated to. -}
+	racedetected expectedref parentrefs
+		| expectedref `elem` parentrefs = False -- good parent
+		| otherwise = True -- race!
+		
+	{- To recover from the race, union merge the lost refs
+	 - into the index, and recommit on top of the bad commit. -}
+	fixrace committedref lostrefs = do
+		mergeIndex jl lostrefs
+		commitIndex jl committedref racemessage [committedref]
+		
+	racemessage = message ++ " (recovery from race)"
+
+{- Lists all files on the branch. There may be duplicates in the list. -}
+files :: Annex [FilePath]
+files = do
+	update
+	(++)
+		<$> branchFiles
+		<*> getJournalledFilesStale
+
+{- Files in the branch, not including any from journalled changes,
+ - and without updating the branch. -}
+branchFiles :: Annex [FilePath]
+branchFiles = withIndex $ inRepo $ Git.Command.pipeNullSplitZombie
+	[ Params "ls-tree --name-only -r -z"
+	, Param $ fromRef fullname
+	]
+
+{- Populates the branch's index file with the current branch contents.
+ - 
+ - This is only done when the index doesn't yet exist, and the index 
+ - is used to build up changes to be commited to the branch, and merge
+ - in changes from other branches.
+ -}
+genIndex :: Git.Repo -> IO ()
+genIndex g = Git.UpdateIndex.streamUpdateIndex g
+	[Git.UpdateIndex.lsTree fullname g]
+
+{- Merges the specified refs into the index.
+ - Any changes staged in the index will be preserved. -}
+mergeIndex :: JournalLocked -> [Git.Ref] -> Annex ()
+mergeIndex jl branches = do
+	prepareModifyIndex jl
+	h <- catFileHandle
+	inRepo $ \g -> Git.UnionMerge.mergeIndex h g branches
+
+{- Removes any stale git lock file, to avoid git falling over when
+ - updating the index.
+ -
+ - Since all modifications of the index are performed inside this module,
+ - and only when the journal is locked, the fact that the journal has to be
+ - locked when this is called ensures that no other process is currently
+ - modifying the index. So any index.lock file must be stale, caused
+ - by git running when the system crashed, or the repository's disk was
+ - removed, etc.
+ -}
+prepareModifyIndex :: JournalLocked -> Annex ()
+prepareModifyIndex _jl = do
+	index <- fromRepo gitAnnexIndex
+	void $ liftIO $ tryIO $ removeFile $ index ++ ".lock"
+
+{- Runs an action using the branch's index file. -}
+withIndex :: Annex a -> Annex a
+withIndex = withIndex' False
+withIndex' :: Bool -> Annex a -> Annex a
+withIndex' bootstrapping a = do
+	f <- fromRepo gitAnnexIndex
+	withIndexFile f $ do
+		checkIndexOnce $ unlessM (liftIO $ doesFileExist f) $ do
+			unless bootstrapping create
+			createAnnexDirectory $ takeDirectory f
+			unless bootstrapping $ inRepo genIndex
+		a
+
+{- Updates the branch's index to reflect the current contents of the branch.
+ - Any changes staged in the index will be preserved.
+ -
+ - Compares the ref stored in the lock file with the current
+ - ref of the branch to see if an update is needed.
+ -}
+updateIndex :: JournalLocked -> Git.Ref -> Annex ()
+updateIndex jl branchref = whenM (needUpdateIndex branchref) $
+	forceUpdateIndex jl branchref
+
+forceUpdateIndex :: JournalLocked -> Git.Ref -> Annex ()
+forceUpdateIndex jl branchref = do
+	withIndex $ mergeIndex jl [fullname]
+	setIndexSha branchref
+
+{- Checks if the index needs to be updated. -}
+needUpdateIndex :: Git.Ref -> Annex Bool
+needUpdateIndex branchref = do
+	f <- fromRepo gitAnnexIndexStatus
+	committedref <- Git.Ref . firstLine <$>
+		liftIO (catchDefaultIO "" $ readFileStrict f)
+	return (committedref /= branchref)
+
+{- Record that the branch's index has been updated to correspond to a
+ - given ref of the branch. -}
+setIndexSha :: Git.Ref -> Annex ()
+setIndexSha ref = do
+	f <- fromRepo gitAnnexIndexStatus
+	liftIO $ writeFile f $ fromRef ref ++ "\n"
+	setAnnexFilePerm f
+
+{- Stages the journal into the index and returns an action that will
+ - clean up the staged journal files, which should only be run once
+ - the index has been committed to the branch.
+ -
+ - Before staging, this removes any existing git index file lock.
+ - This is safe to do because stageJournal is the only thing that
+ - modifies this index file, and only one can run at a time, because
+ - the journal is locked. So any existing git index file lock must be
+ - stale, and the journal must contain any data that was in the process
+ - of being written to the index file when it crashed.
+ -}
+stageJournal :: JournalLocked -> Annex (IO ())
+stageJournal jl = withIndex $ do
+	prepareModifyIndex jl
+	g <- gitRepo
+	let dir = gitAnnexJournalDir g
+	fs <- getJournalFiles jl
+	liftIO $ do
+		h <- hashObjectStart g
+		Git.UpdateIndex.streamUpdateIndex g
+			[genstream dir h fs]
+		hashObjectStop h
+	return $ liftIO $ mapM_ (removeFile . (dir </>)) fs
+  where
+	genstream dir h fs streamer = forM_ fs $ \file -> do
+		let path = dir </> file
+		sha <- hashFile h path
+		streamer $ Git.UpdateIndex.updateIndexLine
+			sha FileBlob (asTopFilePath $ fileJournal file)
+
+{- This is run after the refs have been merged into the index,
+ - but before the result is committed to the branch.
+ - (Which is why it's passed the contents of the local branches's
+ - transition log before that merge took place.)
+ -
+ - When the refs contain transitions that have not yet been done locally,
+ - the transitions are performed on the index, and a new branch
+ - is created from the result.
+ -
+ - When there are transitions recorded locally that have not been done
+ - to the remote refs, the transitions are performed in the index,
+ - and committed to the existing branch. In this case, the untransitioned
+ - remote refs cannot be merged into the branch (since transitions
+ - throw away history), so they are added to the list of refs to ignore,
+ - to avoid re-merging content from them again.
+ -}
+handleTransitions :: JournalLocked -> Transitions -> [Git.Ref] -> Annex Bool
+handleTransitions jl localts refs = do
+	m <- M.fromList <$> mapM getreftransition refs
+	let remotets = M.elems m
+	if all (localts ==) remotets
+		then return False
+		else do
+			let allts = combineTransitions (localts:remotets)
+			let (transitionedrefs, untransitionedrefs) =
+				partition (\r -> M.lookup r m == Just allts) refs
+			performTransitionsLocked jl allts (localts /= allts) transitionedrefs
+			ignoreRefs untransitionedrefs
+			return True
+  where
+  	getreftransition ref = do
+		ts <- parseTransitionsStrictly "remote" . L.unpack
+			<$> catFile ref transitionsLog
+		return (ref, ts)
+
+ignoreRefs :: [Git.Ref] -> Annex ()
+ignoreRefs rs = do
+	old <- getIgnoredRefs
+	let s = S.unions [old, S.fromList rs]
+	f <- fromRepo gitAnnexIgnoredRefs
+	replaceFile f $ \tmp -> liftIO $ writeFile tmp $
+		unlines $ map fromRef $ S.elems s
+
+getIgnoredRefs :: Annex (S.Set Git.Ref)
+getIgnoredRefs = S.fromList . mapMaybe Git.Sha.extractSha . lines <$> content
+  where
+  	content = do
+		f <- fromRepo gitAnnexIgnoredRefs
+		liftIO $ catchDefaultIO "" $ readFile f
+
+{- Performs the specified transitions on the contents of the index file,
+ - commits it to the branch, or creates a new branch.
+ -}
+performTransitions :: Transitions -> Bool -> [Ref] -> Annex ()
+performTransitions ts neednewlocalbranch transitionedrefs = lockJournal $ \jl ->
+	performTransitionsLocked jl ts neednewlocalbranch transitionedrefs
+performTransitionsLocked :: JournalLocked -> Transitions -> Bool -> [Ref] -> Annex ()
+performTransitionsLocked jl ts neednewlocalbranch transitionedrefs = do
+	-- For simplicity & speed, we're going to use the Annex.Queue to
+	-- update the git-annex branch, while it usually holds changes
+	-- for the head branch. Flush any such changes.
+	Annex.Queue.flush
+	withIndex $ do
+		prepareModifyIndex jl
+		run $ mapMaybe getTransitionCalculator $ transitionList ts
+		Annex.Queue.flush
+		if neednewlocalbranch
+			then do
+				committedref <- inRepo $ Git.Branch.commitAlways message fullname transitionedrefs
+				setIndexSha committedref
+			else do
+				ref <- getBranch
+				commitIndex jl ref message (nub $ fullname:transitionedrefs)
+  where
+  	message
+		| neednewlocalbranch && null transitionedrefs = "new branch for transition " ++ tdesc
+		| otherwise = "continuing transition " ++ tdesc
+	tdesc = show $ map describeTransition $ transitionList ts
+
+	{- The changes to make to the branch are calculated and applied to
+	 - the branch directly, rather than going through the journal,
+	 - which would be innefficient. (And the journal is not designed
+	 - to hold changes to every file in the branch at once.)
+	 -
+	 - When a file in the branch is changed by transition code,
+	 - that value is remembered and fed into the code for subsequent
+	 - transitions.
+	 -}
+	run [] = noop
+	run changers = do
+		trustmap <- calcTrustMap <$> getRaw trustLog
+		fs <- branchFiles
+		hasher <- inRepo hashObjectStart
+		forM_ fs $ \f -> do
+			content <- getRaw f
+			apply changers hasher f content trustmap
+		liftIO $ hashObjectStop hasher
+	apply [] _ _ _ _ = return ()
+	apply (changer:rest) hasher file content trustmap =
+		case changer file content trustmap of
+			RemoveFile -> do
+				Annex.Queue.addUpdateIndex
+					=<< inRepo (Git.UpdateIndex.unstageFile file)
+				-- File is deleted; can't run any other
+				-- transitions on it.
+				return ()
+			ChangeFile content' -> do
+				sha <- inRepo $ hashObject BlobObject content'
+				Annex.Queue.addUpdateIndex $ Git.UpdateIndex.pureStreamer $
+					Git.UpdateIndex.updateIndexLine sha FileBlob (asTopFilePath file)
+				apply rest hasher file content' trustmap
+			PreserveFile ->
+				apply rest hasher file content trustmap

Annex/Branch/Transitions.hs

@@ -0,0 +1,60 @@
+{- git-annex branch transitions
+ -
+ - Copyright 2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Annex.Branch.Transitions (
+	FileTransition(..),
+	getTransitionCalculator
+) where
+
+import Logs
+import Logs.Transitions
+import Logs.UUIDBased as UUIDBased
+import Logs.Presence.Pure as Presence
+import Types.TrustLevel
+import Types.UUID
+
+import qualified Data.Map as M
+
+data FileTransition
+	= ChangeFile String
+	| RemoveFile
+	| PreserveFile
+
+type TransitionCalculator = FilePath -> String -> TrustMap -> FileTransition
+
+getTransitionCalculator :: Transition -> Maybe TransitionCalculator
+getTransitionCalculator ForgetGitHistory = Nothing
+getTransitionCalculator ForgetDeadRemotes = Just dropDead
+
+dropDead :: FilePath -> String -> TrustMap -> FileTransition
+dropDead f content trustmap = case getLogVariety f of
+	Just UUIDBasedLog
+		-- Don't remove the dead repo from the trust log,
+		-- because git remotes may still exist, and they need
+		-- to still know it's dead.
+		| f == trustLog -> PreserveFile
+		| otherwise -> ChangeFile $ UUIDBased.showLog id $ dropDeadFromUUIDBasedLog trustmap $ UUIDBased.parseLog Just content
+	Just NewUUIDBasedLog -> ChangeFile $
+		UUIDBased.showLogNew id $ dropDeadFromUUIDBasedLog trustmap $ UUIDBased.parseLogNew Just content
+	Just (PresenceLog _) ->
+		let newlog = Presence.compactLog $ dropDeadFromPresenceLog trustmap $ Presence.parseLog content
+		in if null newlog
+			then RemoveFile
+			else ChangeFile $ Presence.showLog newlog
+	Just OtherLog -> PreserveFile
+	Nothing -> PreserveFile
+
+dropDeadFromUUIDBasedLog :: TrustMap -> UUIDBased.Log String -> UUIDBased.Log String
+dropDeadFromUUIDBasedLog trustmap = M.filterWithKey $ notDead trustmap . const
+
+{- Presence logs can contain UUIDs or other values. Any line that matches
+ - a dead uuid is dropped; any other values are passed through. -}
+dropDeadFromPresenceLog :: TrustMap -> [Presence.LogLine] -> [Presence.LogLine]
+dropDeadFromPresenceLog trustmap = filter $ notDead trustmap (toUUID . Presence.info)
+
+notDead :: TrustMap -> (v -> UUID) -> v -> Bool
+notDead trustmap a v = M.findWithDefault SemiTrusted (a v) trustmap /= DeadTrusted

Annex/BranchState.hs

@@ -0,0 +1,43 @@
+{- git-annex branch state management
+ -
+ - Runtime state about the git-annex branch.
+ -
+ - Copyright 2011-2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Annex.BranchState where
+
+import Common.Annex
+import Types.BranchState
+import qualified Annex
+
+getState :: Annex BranchState
+getState = Annex.getState Annex.branchstate
+
+setState :: BranchState -> Annex ()
+setState state = Annex.changeState $ \s -> s { Annex.branchstate = state }
+
+changeState :: (BranchState -> BranchState) -> Annex ()
+changeState changer = setState =<< changer <$> getState
+
+{- Runs an action to check that the index file exists, if it's not been
+ - checked before in this run of git-annex. -}
+checkIndexOnce :: Annex () -> Annex ()
+checkIndexOnce a = unlessM (indexChecked <$> getState) $ do
+	a
+	changeState $ \s -> s { indexChecked = True }
+
+{- Runs an action to update the branch, if it's not been updated before
+ - in this run of git-annex. -}
+runUpdateOnce :: Annex () -> Annex ()
+runUpdateOnce a = unlessM (branchUpdated <$> getState) $ do
+	a
+	disableUpdate
+
+{- Avoids updating the branch. A useful optimisation when the branch
+ - is known to have not changed, or git-annex won't be relying on info
+ - from it. -}
+disableUpdate :: Annex ()
+disableUpdate = changeState $ \s -> s { branchUpdated = True }

Annex/CatFile.hs

@@ -0,0 +1,144 @@
+{- git cat-file interface, with handle automatically stored in the Annex monad
+ -
+ - Copyright 2011-2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Annex.CatFile (
+	catFile,
+	catFileDetails,
+	catObject,
+	catTree,
+	catObjectDetails,
+	catFileHandle,
+	catKey,
+	catKeyFile,
+	catKeyFileHEAD,
+) where
+
+import qualified Data.ByteString.Lazy as L
+import qualified Data.Map as M
+import System.PosixCompat.Types
+
+import Common.Annex
+import qualified Git
+import qualified Git.CatFile
+import qualified Annex
+import Git.Types
+import Git.FilePath
+import Git.FileMode
+import qualified Git.Ref
+
+catFile :: Git.Branch -> FilePath -> Annex L.ByteString
+catFile branch file = do
+	h <- catFileHandle
+	liftIO $ Git.CatFile.catFile h branch file
+
+catFileDetails :: Git.Branch -> FilePath -> Annex (Maybe (L.ByteString, Sha, ObjectType))
+catFileDetails branch file = do
+	h <- catFileHandle
+	liftIO $ Git.CatFile.catFileDetails h branch file
+
+catObject :: Git.Ref -> Annex L.ByteString
+catObject ref = do
+	h <- catFileHandle
+	liftIO $ Git.CatFile.catObject h ref
+
+catTree :: Git.Ref -> Annex [(FilePath, FileMode)]
+catTree ref = do
+	h <- catFileHandle
+	liftIO $ Git.CatFile.catTree h ref
+
+catObjectDetails :: Git.Ref -> Annex (Maybe (L.ByteString, Sha, ObjectType))
+catObjectDetails ref = do
+	h <- catFileHandle
+	liftIO $ Git.CatFile.catObjectDetails h ref
+
+{- There can be multiple index files, and a different cat-file is needed
+ - for each. This is selected by setting GIT_INDEX_FILE in the gitEnv. -}
+catFileHandle :: Annex Git.CatFile.CatFileHandle
+catFileHandle = do
+	m <- Annex.getState Annex.catfilehandles
+	indexfile <- fromMaybe "" . maybe Nothing (lookup "GIT_INDEX_FILE")
+		<$> fromRepo gitEnv
+	case M.lookup indexfile m of
+		Just h -> return h
+		Nothing -> do
+			h <- inRepo Git.CatFile.catFileStart
+			let m' = M.insert indexfile h m
+			Annex.changeState $ \s -> s { Annex.catfilehandles = m' }
+			return h
+
+{- From the Sha or Ref of a symlink back to the key.
+ -
+ - Requires a mode witness, to guarantee that the file is a symlink.
+ -}
+catKey :: Ref -> FileMode -> Annex (Maybe Key)
+catKey = catKey' True
+
+catKey' :: Bool -> Ref -> FileMode -> Annex (Maybe Key)
+catKey' modeguaranteed ref mode
+	| isSymLink mode = do
+		l <- fromInternalGitPath . decodeBS <$> get
+		return $ if isLinkToAnnex l
+			then fileKey $ takeFileName l
+			else Nothing
+	| otherwise = return Nothing
+  where
+  	-- If the mode is not guaranteed to be correct, avoid
+	-- buffering the whole file content, which might be large.
+	-- 8192 is enough if it really is a symlink.
+  	get
+		| modeguaranteed = catObject ref
+		| otherwise = L.take 8192 <$> catObject ref
+
+{- Looks up the key corresponding to the Ref using the running cat-file.
+ -
+ - Currently this always has to look in HEAD, because cat-file --batch
+ - does not offer a way to specify that we want to look up a tree object
+ - in the index. So if the index has a file staged not as a symlink,
+ - and it is a symlink in head, the wrong mode is gotten.
+ - Also, we have to assume the file is a symlink if it's not yet committed
+ - to HEAD. For these reasons, modeguaranteed is not set.
+ -}
+catKeyChecked :: Bool -> Ref -> Annex (Maybe Key)
+catKeyChecked needhead ref@(Ref r) =
+	catKey' False ref =<< findmode <$> catTree treeref
+  where
+  	pathparts = split "/" r
+	dir = intercalate "/" $ take (length pathparts - 1) pathparts
+	file = fromMaybe "" $ lastMaybe pathparts
+	treeref = Ref $ if needhead then "HEAD" ++ dir ++ "/" else dir ++ "/"
+	findmode = fromMaybe symLinkMode . headMaybe .
+		 map snd . filter (\p -> fst p == file)
+
+{- From a file in the repository back to the key.
+ -
+ - Ideally, this should reflect the key that's staged in the index,
+ - not the key that's committed to HEAD. Unfortunately, git cat-file
+ - does not refresh the index file after it's started up, so things
+ - newly staged in the index won't show up. It does, however, notice
+ - when branches change.
+ -
+ - For command-line git-annex use, that doesn't matter. It's perfectly
+ - reasonable for things staged in the index after the currently running
+ - git-annex process to not be noticed by it. However, we do want to see
+ - what's in the index, since it may have uncommitted changes not in HEAD
+ -
+ - For the assistant, this is much more of a problem, since it commits
+ - files and then needs to be able to immediately look up their keys.
+ - OTOH, the assistant doesn't keep changes staged in the index for very
+ - long at all before committing them -- and it won't look at the keys
+ - of files until after committing them.
+ -
+ - So, this gets info from the index, unless running as a daemon.
+ -}
+catKeyFile :: FilePath -> Annex (Maybe Key)
+catKeyFile f = ifM (Annex.getState Annex.daemon)
+	( catKeyFileHEAD f
+	, catKeyChecked True $ Git.Ref.fileRef f
+	)
+
+catKeyFileHEAD :: FilePath -> Annex (Maybe Key)
+catKeyFileHEAD f = catKeyChecked False $ Git.Ref.fileFromRef Git.Ref.headRef f

Annex/CheckAttr.hs

@@ -0,0 +1,35 @@
+{- git check-attr interface, with handle automatically stored in the Annex monad
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Annex.CheckAttr (
+	checkAttr,
+	checkAttrHandle
+) where
+
+import Common.Annex
+import qualified Git.CheckAttr as Git
+import qualified Annex
+
+{- All gitattributes used by git-annex. -}
+annexAttrs :: [Git.Attr]
+annexAttrs =
+	[ "annex.backend"
+	, "annex.numcopies"
+	]
+
+checkAttr :: Git.Attr -> FilePath -> Annex String
+checkAttr attr file = do
+	h <- checkAttrHandle
+	liftIO $ Git.checkAttr h attr file
+
+checkAttrHandle :: Annex Git.CheckAttrHandle
+checkAttrHandle = maybe startup return =<< Annex.getState Annex.checkattrhandle
+  where
+	startup = do
+		h <- inRepo $ Git.checkAttrStart annexAttrs
+		Annex.changeState $ \s -> s { Annex.checkattrhandle = Just h }
+		return h

Annex/CheckIgnore.hs

@@ -0,0 +1,32 @@
+{- git check-ignore interface, with handle automatically stored in
+ - the Annex monad
+ -
+ - Copyright 2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Annex.CheckIgnore (
+	checkIgnored,
+	checkIgnoreHandle
+) where
+
+import Common.Annex
+import qualified Git.CheckIgnore as Git
+import qualified Annex
+
+checkIgnored :: FilePath -> Annex Bool
+checkIgnored file = go =<< checkIgnoreHandle
+  where
+  	go Nothing = return False
+	go (Just h) = liftIO $ Git.checkIgnored h file
+
+checkIgnoreHandle :: Annex (Maybe Git.CheckIgnoreHandle)
+checkIgnoreHandle = maybe startup return =<< Annex.getState Annex.checkignorehandle
+  where
+	startup = do
+		v <- inRepo Git.checkIgnoreStart
+		when (isNothing v) $
+			warning "The installed version of git is too old for .gitignores to be honored by git-annex."
+		Annex.changeState $ \s -> s { Annex.checkignorehandle = Just v }
+		return v

Annex/Content.hs

@@ -0,0 +1,624 @@
+{- git-annex file content managing
+ -
+ - Copyright 2010-2014 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE CPP #-}
+
+module Annex.Content (
+	inAnnex,
+	inAnnexSafe,
+	inAnnexCheck,
+	lockContent,
+	getViaTmp,
+	getViaTmpChecked,
+	getViaTmpUnchecked,
+	prepGetViaTmpChecked,
+	withTmp,
+	checkDiskSpace,
+	moveAnnex,
+	sendAnnex,
+	prepSendAnnex,
+	removeAnnex,
+	fromAnnex,
+	moveBad,
+	KeyLocation(..),
+	getKeysPresent,
+	saveState,
+	downloadUrl,
+	preseedTmp,
+	freezeContent,
+	thawContent,
+	dirKeys,
+	withObjectLoc,
+) where
+
+import System.IO.Unsafe (unsafeInterleaveIO)
+
+import Common.Annex
+import Logs.Location
+import qualified Git
+import qualified Annex
+import qualified Annex.Queue
+import qualified Annex.Branch
+import Utility.DiskFree
+import Utility.FileMode
+import qualified Annex.Url as Url
+import Types.Key
+import Utility.DataUnits
+import Utility.CopyFile
+import Config
+import Git.SharedRepository
+import Annex.Perms
+import Annex.Link
+import Annex.Content.Direct
+import Annex.ReplaceFile
+import Annex.Exception
+
+#ifdef mingw32_HOST_OS
+import Utility.WinLock
+#endif
+
+{- Checks if a given key's content is currently present. -}
+inAnnex :: Key -> Annex Bool
+inAnnex key = inAnnexCheck key $ liftIO . doesFileExist
+
+{- Runs an arbitrary check on a key's content. -}
+inAnnexCheck :: Key -> (FilePath -> Annex Bool) -> Annex Bool
+inAnnexCheck key check = inAnnex' id False check key
+
+{- Generic inAnnex, handling both indirect and direct mode.
+ -
+ - In direct mode, at least one of the associated files must pass the
+ - check. Additionally, the file must be unmodified.
+ -}
+inAnnex' :: (a -> Bool) -> a -> (FilePath -> Annex a) -> Key -> Annex a
+inAnnex' isgood bad check key = withObjectLoc key checkindirect checkdirect
+  where
+	checkindirect loc = do
+		whenM (fromRepo Git.repoIsUrl) $
+			error "inAnnex cannot check remote repo"
+		check loc
+	checkdirect [] = return bad
+	checkdirect (loc:locs) = do
+		r <- check loc
+		if isgood r
+			then ifM (goodContent key loc)
+				( return r
+				, checkdirect locs
+				)
+			else checkdirect locs
+
+{- A safer check; the key's content must not only be present, but
+ - is not in the process of being removed. -}
+inAnnexSafe :: Key -> Annex (Maybe Bool)
+inAnnexSafe key = inAnnex' (fromMaybe False) (Just False) go key
+  where
+	is_locked = Nothing
+	is_unlocked = Just True
+	is_missing = Just False
+
+	go contentfile = maybe (checkindirect contentfile) (checkdirect contentfile)
+		=<< contentLockFile key
+
+#ifndef mingw32_HOST_OS
+	checkindirect f = liftIO $ openforlock f >>= check is_missing
+	{- In direct mode, the content file must exist, but
+	 - the lock file often generally won't exist unless a removal is in
+	 - process. This does not create the lock file, it only checks for
+	 - it. -}
+	checkdirect contentfile lockfile = liftIO $
+		ifM (doesFileExist contentfile)
+			( openforlock lockfile >>= check is_unlocked
+			, return is_missing
+			)
+	openforlock f = catchMaybeIO $
+		openFd f ReadOnly Nothing defaultFileFlags
+	check _ (Just h) = do
+		v <- getLock h (ReadLock, AbsoluteSeek, 0, 0)
+		closeFd h
+		return $ case v of
+			Just _ -> is_locked
+			Nothing -> is_unlocked
+	check def Nothing = return def
+#else
+	checkindirect _ = return is_missing
+	{- In Windows, see if we can take a shared lock. If so, 
+	 - remove the lock file to clean up after ourselves. -}
+	checkdirect contentfile lockfile =
+		ifM (liftIO $ doesFileExist contentfile)
+			( modifyContent lockfile $ liftIO $ do
+				v <- lockShared lockfile
+				case v of
+					Nothing -> return is_locked
+					Just lockhandle -> do
+						dropLock lockhandle
+						void $ tryIO $ nukeFile lockfile
+						return is_unlocked
+			, return is_missing
+			)
+#endif
+
+{- Direct mode and especially Windows has to use a separate lock
+ - file from the content, since locking the actual content file
+ - would interfere with the user's use of it. -}
+contentLockFile :: Key -> Annex (Maybe FilePath)
+contentLockFile key = ifM isDirect
+	( Just <$> calcRepo (gitAnnexContentLock key)
+	, return Nothing
+	)
+
+{- Content is exclusively locked while running an action that might remove
+ - it. (If the content is not present, no locking is done.) -}
+lockContent :: Key -> Annex a -> Annex a
+lockContent key a = do
+	contentfile <- calcRepo $ gitAnnexLocation key
+	lockfile <- contentLockFile key
+	maybe noop setuplockfile lockfile
+	bracketAnnex (liftIO $ lock contentfile lockfile) (unlock lockfile) (const a)
+  where
+	alreadylocked = error "content is locked"
+	setuplockfile lockfile = modifyContent lockfile $
+		void $ liftIO $ tryIO $
+			writeFile lockfile ""
+	cleanuplockfile lockfile = modifyContent lockfile $
+		void $ liftIO $ tryIO $
+			nukeFile lockfile
+#ifndef mingw32_HOST_OS
+	lock contentfile Nothing = opencontentforlock contentfile >>= dolock
+	lock _ (Just lockfile) = openforlock lockfile >>= dolock . Just
+	{- Since content files are stored with the write bit disabled, have
+	 - to fiddle with permissions to open for an exclusive lock. -}
+	opencontentforlock f = catchMaybeIO $ ifM (doesFileExist f)
+		( withModifiedFileMode f
+			(`unionFileModes` ownerWriteMode)
+			(openforlock f)
+		, openforlock f
+		)
+	openforlock f = openFd f ReadWrite Nothing defaultFileFlags
+	dolock Nothing = return Nothing
+	dolock (Just fd) = do
+		v <- tryIO $ setLock fd (WriteLock, AbsoluteSeek, 0, 0)
+		case v of
+			Left _ -> alreadylocked
+			Right _ -> return $ Just fd
+	unlock mlockfile mfd = do
+		maybe noop cleanuplockfile mlockfile
+		liftIO $ maybe noop closeFd mfd
+#else
+	lock _ (Just lockfile) = maybe alreadylocked (return . Just) =<< lockExclusive lockfile
+	lock _ Nothing = return Nothing
+	unlock mlockfile mlockhandle = do
+		liftIO $ maybe noop dropLock mlockhandle
+		maybe noop cleanuplockfile mlockfile
+#endif
+
+{- Runs an action, passing it a temporary filename to get,
+ - and if the action succeeds, moves the temp file into 
+ - the annex as a key's content. -}
+getViaTmp :: Key -> (FilePath -> Annex Bool) -> Annex Bool
+getViaTmp = getViaTmpChecked (return True)
+
+{- Like getViaTmp, but does not check that there is enough disk space
+ - for the incoming key. For use when the key content is already on disk
+ - and not being copied into place. -}
+getViaTmpUnchecked :: Key -> (FilePath -> Annex Bool) -> Annex Bool
+getViaTmpUnchecked = finishGetViaTmp (return True)
+
+getViaTmpChecked :: Annex Bool -> Key -> (FilePath -> Annex Bool) -> Annex Bool
+getViaTmpChecked check key action = 
+	prepGetViaTmpChecked key $
+		finishGetViaTmp check key action
+
+{- Prepares to download a key via a tmp file, and checks that there is
+ - enough free disk space.
+ -
+ - When the temp file already exists, count the space it is using as
+ - free, since the download will overwrite it or resume.
+ -
+ - Wen there's enough free space, runs the download action.
+ -}
+prepGetViaTmpChecked :: Key -> Annex Bool -> Annex Bool
+prepGetViaTmpChecked key getkey = do
+	tmp <- fromRepo $ gitAnnexTmpObjectLocation key
+
+	e <- liftIO $ doesFileExist tmp
+	alreadythere <- if e
+		then fromIntegral . fileSize <$> liftIO (getFileStatus tmp)
+		else return 0
+	ifM (checkDiskSpace Nothing key alreadythere)
+		( do
+			-- The tmp file may not have been left writable
+			when e $ thawContent tmp
+			getkey
+		, return False
+		)
+
+finishGetViaTmp :: Annex Bool -> Key -> (FilePath -> Annex Bool) -> Annex Bool
+finishGetViaTmp check key action = do
+	tmpfile <- prepTmp key
+	ifM (action tmpfile <&&> check)
+		( do
+			moveAnnex key tmpfile
+			logStatus key InfoPresent
+			return True
+		-- the tmp file is left behind, in case caller wants
+		-- to resume its transfer
+		, return False
+		)
+
+prepTmp :: Key -> Annex FilePath
+prepTmp key = do
+	tmp <- fromRepo $ gitAnnexTmpObjectLocation key
+	createAnnexDirectory (parentDir tmp)
+	return tmp
+
+{- Creates a temp file, runs an action on it, and cleans up the temp file. -}
+withTmp :: Key -> (FilePath -> Annex a) -> Annex a
+withTmp key action = do
+	tmp <- prepTmp key
+	res <- action tmp
+	liftIO $ nukeFile tmp
+	return res
+
+{- Checks that there is disk space available to store a given key,
+ - in a destination (or the annex) printing a warning if not. -}
+checkDiskSpace :: Maybe FilePath -> Key -> Integer -> Annex Bool
+checkDiskSpace destination key alreadythere = do
+	reserve <- annexDiskReserve <$> Annex.getGitConfig
+	free <- liftIO . getDiskFree =<< dir
+	force <- Annex.getState Annex.force
+	case (free, keySize key) of
+		(Just have, Just need) -> do
+			let ok = (need + reserve <= have + alreadythere) || force
+			unless ok $
+				needmorespace (need + reserve - have - alreadythere)
+			return ok
+		_ -> return True
+  where
+	dir = maybe (fromRepo gitAnnexDir) return destination
+	needmorespace n =
+		warning $ "not enough free space, need " ++ 
+			roughSize storageUnits True n ++
+			" more" ++ forcemsg
+	forcemsg = " (use --force to override this check or adjust annex.diskreserve)"
+
+{- Moves a key's content into .git/annex/objects/
+ -
+ - In direct mode, moves it to the associated file, or files.
+ -
+ - What if the key there already has content? This could happen for
+ - various reasons; perhaps the same content is being annexed again.
+ - Perhaps there has been a hash collision generating the keys.
+ -
+ - The current strategy is to assume that in this case it's safe to delete
+ - one of the two copies of the content; and the one already in the annex
+ - is left there, assuming it's the original, canonical copy.
+ -
+ - I considered being more paranoid, and checking that both files had
+ - the same content. Decided against it because A) users explicitly choose
+ - a backend based on its hashing properties and so if they're dealing
+ - with colliding files it's their own fault and B) adding such a check
+ - would not catch all cases of colliding keys. For example, perhaps 
+ - a remote has a key; if it's then added again with different content then
+ - the overall system now has two different peices of content for that
+ - key, and one of them will probably get deleted later. So, adding the
+ - check here would only raise expectations that git-annex cannot truely
+ - meet.
+ -}
+moveAnnex :: Key -> FilePath -> Annex ()
+moveAnnex key src = withObjectLoc key storeobject storedirect
+  where
+	storeobject dest = ifM (liftIO $ doesFileExist dest)
+		( alreadyhave
+		, modifyContent dest $ do
+			liftIO $ moveFile src dest
+			freezeContent dest
+		)
+	storeindirect = storeobject =<< calcRepo (gitAnnexLocation key)
+
+	{- In direct mode, the associated file's content may be locally
+	 - modified. In that case, it's preserved. However, the content
+	 - we're moving into the annex may be the only extant copy, so
+	 - it's important we not lose it. So, when the key's content
+	 - cannot be moved to any associated file, it's stored in indirect
+	 - mode.
+	 -}
+	storedirect = storedirect' storeindirect
+	storedirect' fallback [] = fallback
+	storedirect' fallback (f:fs) = do
+		thawContent src
+		v <- isAnnexLink f
+		if Just key == v
+			then do
+				updateInodeCache key src
+				replaceFile f $ liftIO . moveFile src
+				chmodContent f
+				forM_ fs $
+					addContentWhenNotPresent key f
+			else ifM (goodContent key f)
+				( storedirect' alreadyhave fs
+				, storedirect' fallback fs
+				)
+	
+	alreadyhave = liftIO $ removeFile src
+
+{- Runs an action to transfer an object's content.
+ -
+ - In direct mode, it's possible for the file to change as it's being sent.
+ - If this happens, runs the rollback action and returns False. The
+ - rollback action should remove the data that was transferred.
+ -}
+sendAnnex :: Key -> Annex () -> (FilePath -> Annex Bool) -> Annex Bool
+sendAnnex key rollback sendobject = go =<< prepSendAnnex key
+  where
+	go Nothing = return False
+	go (Just (f, checksuccess)) = do
+		r <- sendobject f
+		ifM checksuccess
+			( return r
+			, do
+				rollback
+				return False
+			)
+
+{- Returns a file that contains an object's content,
+ - and an check to run after the transfer is complete.
+ -
+ - In direct mode, it's possible for the file to change as it's being sent,
+ - and the check detects this case and returns False.
+ -
+ - Note that the returned check action is, in some cases, run in the
+ - Annex monad of the remote that is receiving the object, rather than
+ - the sender. So it cannot rely on Annex state.
+ -}
+prepSendAnnex :: Key -> Annex (Maybe (FilePath, Annex Bool))
+prepSendAnnex key = withObjectLoc key indirect direct
+  where
+	indirect f = return $ Just (f, return True)
+	direct [] = return Nothing
+	direct (f:fs) = do
+		cache <- recordedInodeCache key
+		-- check that we have a good file
+		ifM (sameInodeCache f cache)
+			( return $ Just (f, sameInodeCache f cache)
+			, direct fs
+			)
+
+{- Performs an action, passing it the location to use for a key's content.
+ -
+ - In direct mode, the associated files will be passed. But, if there are
+ - no associated files for a key, the indirect mode action will be
+ - performed instead. -}
+withObjectLoc :: Key -> (FilePath -> Annex a) -> ([FilePath] -> Annex a) -> Annex a
+withObjectLoc key indirect direct = ifM isDirect
+	( do
+		fs <- associatedFiles key
+		if null fs
+			then goindirect
+			else direct fs
+	, goindirect
+	)
+  where
+	goindirect = indirect =<< calcRepo (gitAnnexLocation key)
+
+cleanObjectLoc :: Key -> Annex () -> Annex ()
+cleanObjectLoc key cleaner = do
+	file <- calcRepo $ gitAnnexLocation key
+	void $ tryAnnexIO $ thawContentDir file
+	cleaner
+	liftIO $ removeparents file (3 :: Int)
+  where
+	removeparents _ 0 = noop
+	removeparents file n = do
+		let dir = parentDir file
+		maybe noop (const $ removeparents dir (n-1))
+			<=< catchMaybeIO $ removeDirectory dir
+
+{- Removes a key's file from .git/annex/objects/
+ -
+ - In direct mode, deletes the associated files or files, and replaces
+ - them with symlinks. -}
+removeAnnex :: Key -> Annex ()
+removeAnnex key = withObjectLoc key remove removedirect
+  where
+	remove file = cleanObjectLoc key $ do
+		secureErase file
+		liftIO $ nukeFile file
+		removeInodeCache key
+	removedirect fs = do
+		cache <- recordedInodeCache key
+		removeInodeCache key
+		mapM_ (resetfile cache) fs
+	resetfile cache f = whenM (sameInodeCache f cache) $ do
+		l <- inRepo $ gitAnnexLink f key
+		secureErase f
+		replaceFile f $ makeAnnexLink l
+
+{- Runs the secure erase command if set, otherwise does nothing.
+ - File may or may not be deleted at the end; caller is responsible for
+ - making sure it's deleted. -}
+secureErase :: FilePath -> Annex ()
+secureErase file = maybe noop go =<< annexSecureEraseCommand <$> Annex.getGitConfig
+  where
+  	go basecmd = void $ liftIO $
+		boolSystem "sh" [Param "-c", Param $ gencmd basecmd]
+	gencmd = massReplace [ ("%file", shellEscape file) ]
+
+{- Moves a key's file out of .git/annex/objects/ -}
+fromAnnex :: Key -> FilePath -> Annex ()
+fromAnnex key dest = cleanObjectLoc key $ do
+	file <- calcRepo $ gitAnnexLocation key
+	thawContent file
+	liftIO $ moveFile file dest
+
+{- Moves a key out of .git/annex/objects/ into .git/annex/bad, and
+ - returns the file it was moved to. -}
+moveBad :: Key -> Annex FilePath
+moveBad key = do
+	src <- calcRepo $ gitAnnexLocation key
+	bad <- fromRepo gitAnnexBadDir
+	let dest = bad </> takeFileName src
+	createAnnexDirectory (parentDir dest)
+	cleanObjectLoc key $
+		liftIO $ moveFile src dest
+	logStatus key InfoMissing
+	return dest
+
+data KeyLocation = InAnnex | InRepository
+
+{- List of keys whose content exists in the specified location.
+ 
+ - InAnnex only lists keys under .git/annex/objects,
+ - while InRepository, in direct mode, also finds keys located in the
+ - work tree.
+ -
+ - Note that InRepository has to check whether direct mode files
+ - have goodContent.
+ -}
+getKeysPresent :: KeyLocation -> Annex [Key]
+getKeysPresent keyloc = do
+	direct <- isDirect
+	dir <- fromRepo gitAnnexObjectDir
+	s <- getstate direct
+	liftIO $ traverse s direct (2 :: Int) dir
+  where
+	traverse s direct depth dir = do
+		contents <- catchDefaultIO [] (dirContents dir)
+		if depth == 0
+			then do
+				contents' <- filterM (present s direct) contents
+				let keys = mapMaybe (fileKey . takeFileName) contents'
+				continue keys []
+			else do
+				let deeper = traverse s direct (depth - 1)
+				continue [] (map deeper contents)
+	continue keys [] = return keys
+	continue keys (a:as) = do
+		{- Force lazy traversal with unsafeInterleaveIO. -}
+		morekeys <- unsafeInterleaveIO a
+		continue (morekeys++keys) as
+
+	present _ False d = presentInAnnex d
+	present s True d = presentDirect s d <||> presentInAnnex d
+
+	presentInAnnex = doesFileExist . contentfile
+	contentfile d = d </> takeFileName d
+
+	presentDirect s d = case keyloc of
+		InAnnex -> return False
+		InRepository -> case fileKey (takeFileName d) of
+			Nothing -> return False
+			Just k -> Annex.eval s $ 
+				anyM (goodContent k) =<< associatedFiles k
+
+	{- In order to run Annex monad actions within unsafeInterleaveIO,
+	 - the current state is taken and reused. No changes made to this
+	 - state will be preserved. 
+	 -
+	 - As an optimsation, call inodesChanged to prime the state with
+	 - a cached value that will be used in the call to goodContent.
+	 -}
+	getstate direct = do
+		when direct $
+			void $ inodesChanged
+		Annex.getState id
+
+{- Things to do to record changes to content when shutting down.
+ -
+ - It's acceptable to avoid committing changes to the branch,
+ - especially if performing a short-lived action.
+ -}
+saveState :: Bool -> Annex ()
+saveState nocommit = doSideAction $ do
+	Annex.Queue.flush
+	unless nocommit $
+		whenM (annexAlwaysCommit <$> Annex.getGitConfig) $
+			Annex.Branch.commit "update"
+
+{- Downloads content from any of a list of urls. -}
+downloadUrl :: [Url.URLString] -> FilePath -> Annex Bool
+downloadUrl urls file = go =<< annexWebDownloadCommand <$> Annex.getGitConfig
+  where
+  	go Nothing = Url.withUrlOptions $ \uo ->
+		anyM (\u -> Url.download u file uo) urls
+	go (Just basecmd) = liftIO $ anyM (downloadcmd basecmd) urls
+	downloadcmd basecmd url =
+		boolSystem "sh" [Param "-c", Param $ gencmd url basecmd]
+			<&&> doesFileExist file
+	gencmd url = massReplace
+		[ ("%file", shellEscape file)
+		, ("%url", shellEscape url)
+		]
+
+{- Copies a key's content, when present, to a temp file.
+ - This is used to speed up some rsyncs. -}
+preseedTmp :: Key -> FilePath -> Annex Bool
+preseedTmp key file = go =<< inAnnex key
+  where
+	go False = return False
+	go True = do
+		ok <- copy
+		when ok $ thawContent file
+		return ok
+	copy = ifM (liftIO $ doesFileExist file)
+		( return True
+		, do
+			s <- calcRepo $ gitAnnexLocation key
+			liftIO $ copyFileExternal s file
+		)
+
+{- Blocks writing to an annexed file, and modifies file permissions to
+ - allow reading it, per core.sharedRepository setting. -}
+freezeContent :: FilePath -> Annex ()
+freezeContent file = unlessM crippledFileSystem $
+	liftIO . go =<< fromRepo getSharedRepository
+  where
+	go GroupShared = modifyFileMode file $
+		removeModes writeModes .
+		addModes [ownerReadMode, groupReadMode]
+	go AllShared = modifyFileMode file $
+		removeModes writeModes .
+		addModes readModes
+	go _ = modifyFileMode file $
+		removeModes writeModes .
+		addModes [ownerReadMode]
+
+{- Adjusts read mode of annexed file per core.sharedRepository setting. -}
+chmodContent :: FilePath -> Annex ()
+chmodContent file = unlessM crippledFileSystem $
+	liftIO . go =<< fromRepo getSharedRepository
+  where
+	go GroupShared = modifyFileMode file $
+		addModes [ownerReadMode, groupReadMode]
+	go AllShared = modifyFileMode file $
+		addModes readModes
+	go _ = modifyFileMode file $
+		addModes [ownerReadMode]
+
+{- Allows writing to an annexed file that freezeContent was called on
+ - before. -}
+thawContent :: FilePath -> Annex ()
+thawContent file = unlessM crippledFileSystem $
+	liftIO . go =<< fromRepo getSharedRepository
+  where
+	go GroupShared = groupWriteRead file
+	go AllShared = groupWriteRead file
+	go _ = allowWrite file
+
+{- Finds files directly inside a directory like gitAnnexBadDir 
+ - (not in subdirectories) and returns the corresponding keys. -}
+dirKeys :: (Git.Repo -> FilePath) -> Annex [Key]
+dirKeys dirspec = do
+	dir <- fromRepo dirspec
+	ifM (liftIO $ doesDirectoryExist dir)
+		( do
+			contents <- liftIO $ getDirectoryContents dir
+			files <- liftIO $ filterM doesFileExist $
+				map (dir </>) contents
+			return $ mapMaybe (fileKey . takeFileName) files
+		, return []
+		)
+

Annex/Content/Direct.hs

@@ -0,0 +1,256 @@
+{- git-annex file content managing for direct mode
+ -
+ - Copyright 2012-2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Annex.Content.Direct (
+	associatedFiles,
+	associatedFilesRelative,
+	removeAssociatedFile,
+	removeAssociatedFileUnchecked,
+	removeAssociatedFiles,
+	addAssociatedFile,
+	goodContent,
+	recordedInodeCache,
+	updateInodeCache,
+	addInodeCache,
+	writeInodeCache,
+	compareInodeCaches,
+	compareInodeCachesWith,
+	sameInodeCache,
+	elemInodeCaches,
+	sameFileStatus,
+	removeInodeCache,
+	toInodeCache,
+	inodesChanged,
+	createInodeSentinalFile,
+	addContentWhenNotPresent,
+) where
+
+import Common.Annex
+import qualified Annex
+import Annex.Perms
+import qualified Git
+import Utility.Tmp
+import Logs.Location
+import Utility.InodeCache
+import Utility.CopyFile
+import Annex.ReplaceFile
+import Annex.Link
+
+{- Absolute FilePaths of Files in the tree that are associated with a key. -}
+associatedFiles :: Key -> Annex [FilePath]
+associatedFiles key = do
+	files <- associatedFilesRelative key
+	top <- fromRepo Git.repoPath
+	return $ map (top </>) files
+
+{- List of files in the tree that are associated with a key, relative to
+ - the top of the repo. -}
+associatedFilesRelative :: Key -> Annex [FilePath] 
+associatedFilesRelative key = do
+	mapping <- calcRepo $ gitAnnexMapping key
+	liftIO $ catchDefaultIO [] $ withFile mapping ReadMode $ \h -> do
+		fileEncoding h
+		-- Read strictly to ensure the file is closed
+		-- before changeAssociatedFiles tries to write to it.
+		-- (Especially needed on Windows.)
+		lines <$> hGetContentsStrict h
+
+{- Changes the associated files information for a key, applying a
+ - transformation to the list. Returns new associatedFiles value. -}
+changeAssociatedFiles :: Key -> ([FilePath] -> [FilePath]) -> Annex [FilePath]
+changeAssociatedFiles key transform = do
+	mapping <- calcRepo $ gitAnnexMapping key
+	files <- associatedFilesRelative key
+	let files' = transform files
+	when (files /= files') $
+		modifyContent mapping $
+			liftIO $ viaTmp writeFileAnyEncoding mapping $
+				unlines files'
+	top <- fromRepo Git.repoPath
+	return $ map (top </>) files'
+
+{- Removes the list of associated files. -}
+removeAssociatedFiles :: Key -> Annex ()
+removeAssociatedFiles key = do
+	mapping <- calcRepo $ gitAnnexMapping key
+	modifyContent mapping $
+		liftIO $ nukeFile mapping
+
+{- Removes an associated file. Returns new associatedFiles value.
+ - Checks if this was the last copy of the object, and updates location
+ - log. -}
+removeAssociatedFile :: Key -> FilePath -> Annex [FilePath]
+removeAssociatedFile key file = do
+	fs <- removeAssociatedFileUnchecked key file
+	when (null fs) $
+		logStatus key InfoMissing
+	return fs
+
+{- Removes an associated file. Returns new associatedFiles value. -}
+removeAssociatedFileUnchecked :: Key -> FilePath -> Annex [FilePath]
+removeAssociatedFileUnchecked key file = do
+	file' <- normaliseAssociatedFile file
+	changeAssociatedFiles key $ filter (/= file')
+
+{- Adds an associated file. Returns new associatedFiles value. -}
+addAssociatedFile :: Key -> FilePath -> Annex [FilePath]
+addAssociatedFile key file = do
+	file' <- normaliseAssociatedFile file
+	changeAssociatedFiles key $ \files ->
+		if file' `elem` files
+			then files
+			else file':files
+
+{- Associated files are always stored relative to the top of the repository.
+ - The input FilePath is relative to the CWD, or is absolute. -}
+normaliseAssociatedFile :: FilePath -> Annex FilePath
+normaliseAssociatedFile file = do
+	top <- fromRepo Git.repoPath
+	liftIO $ relPathDirToFile top <$> absPath file
+
+{- Checks if a file in the tree, associated with a key, has not been modified.
+ -
+ - To avoid needing to fsck the file's content, which can involve an
+ - expensive checksum, this relies on a cache that contains the file's
+ - expected mtime and inode.
+ -}
+goodContent :: Key -> FilePath -> Annex Bool
+goodContent key file = sameInodeCache file =<< recordedInodeCache key
+
+{- Gets the recorded inode cache for a key. 
+ -
+ - A key can be associated with multiple files, so may return more than
+ - one. -}
+recordedInodeCache :: Key -> Annex [InodeCache]
+recordedInodeCache key = withInodeCacheFile key $ \f ->
+	liftIO $ catchDefaultIO [] $
+		mapMaybe readInodeCache . lines <$> readFileStrict f
+
+{- Caches an inode for a file.
+ -
+ - Anything else already cached is preserved.
+ -}
+updateInodeCache :: Key -> FilePath -> Annex ()
+updateInodeCache key file = maybe noop (addInodeCache key)
+	=<< liftIO (genInodeCache file)
+
+{- Adds another inode to the cache for a key. -}
+addInodeCache :: Key -> InodeCache -> Annex ()
+addInodeCache key cache = do
+	oldcaches <- recordedInodeCache key
+	unlessM (elemInodeCaches cache oldcaches) $
+		writeInodeCache key (cache:oldcaches)
+
+{- Writes inode cache for a key. -}
+writeInodeCache :: Key -> [InodeCache] -> Annex ()
+writeInodeCache key caches = withInodeCacheFile key $ \f -> 
+	modifyContent f $
+		liftIO $ writeFile f $
+			unlines $ map showInodeCache caches
+
+{- Removes an inode cache. -}
+removeInodeCache :: Key -> Annex ()
+removeInodeCache key = withInodeCacheFile key $ \f ->
+	modifyContent f $
+		liftIO $ nukeFile f
+
+withInodeCacheFile :: Key -> (FilePath -> Annex a) -> Annex a
+withInodeCacheFile key a = a =<< calcRepo (gitAnnexInodeCache key)
+
+{- Checks if a InodeCache matches the current version of a file. -}
+sameInodeCache :: FilePath -> [InodeCache] -> Annex Bool
+sameInodeCache _ [] = return False
+sameInodeCache file old = go =<< liftIO (genInodeCache file)
+  where
+	go Nothing = return False
+	go (Just curr) = elemInodeCaches curr old
+
+{- Checks if a FileStatus matches the recorded InodeCache of a file. -}
+sameFileStatus :: Key -> FileStatus -> Annex Bool
+sameFileStatus key status = do
+	old <- recordedInodeCache key
+	let curr = toInodeCache status
+	case (old, curr) of
+		(_, Just c) -> elemInodeCaches c old
+		([], Nothing) -> return True
+		_ -> return False
+
+{- If the inodes have changed, only the size and mtime are compared. -}
+compareInodeCaches :: InodeCache -> InodeCache -> Annex Bool
+compareInodeCaches x y
+	| compareStrong x y = return True
+	| otherwise = ifM inodesChanged
+		( return $ compareWeak x y
+		, return False
+		)
+
+elemInodeCaches :: InodeCache -> [InodeCache] -> Annex Bool
+elemInodeCaches _ [] = return False
+elemInodeCaches c (l:ls) = ifM (compareInodeCaches c l)
+	( return True
+	, elemInodeCaches c ls
+	)
+
+compareInodeCachesWith :: Annex InodeComparisonType
+compareInodeCachesWith = ifM inodesChanged ( return Weakly, return Strongly )
+
+{- Copies the contentfile to the associated file, if the associated
+ - file has no content. If the associated file does have content,
+ - even if the content differs, it's left unchanged. -}
+addContentWhenNotPresent :: Key -> FilePath -> FilePath -> Annex ()
+addContentWhenNotPresent key contentfile associatedfile = do
+	v <- isAnnexLink associatedfile
+	when (Just key == v) $
+		replaceFile associatedfile $
+			liftIO . void . copyFileExternal contentfile
+	updateInodeCache key associatedfile	
+
+{- Some filesystems get new inodes each time they are mounted.
+ - In order to work on such a filesystem, a sentinal file is used to detect
+ - when the inodes have changed.
+ -
+ - If the sentinal file does not exist, we have to assume that the
+ - inodes have changed.
+ -}
+inodesChanged :: Annex Bool
+inodesChanged = maybe calc return =<< Annex.getState Annex.inodeschanged
+  where
+	calc = do
+		scache <- liftIO . genInodeCache
+			=<< fromRepo gitAnnexInodeSentinal
+		scached <- readInodeSentinalFile
+		let changed = case (scache, scached) of
+			(Just c1, Just c2) -> not $ compareStrong c1 c2
+			_ -> True
+		Annex.changeState $ \s -> s { Annex.inodeschanged = Just changed }
+		return changed
+
+readInodeSentinalFile :: Annex (Maybe InodeCache)
+readInodeSentinalFile = do
+	sentinalcachefile <- fromRepo gitAnnexInodeSentinalCache
+	liftIO $ catchDefaultIO Nothing $
+		readInodeCache <$> readFile sentinalcachefile
+
+writeInodeSentinalFile :: Annex ()
+writeInodeSentinalFile = do
+	sentinalfile <- fromRepo gitAnnexInodeSentinal
+	createAnnexDirectory (parentDir sentinalfile)
+	sentinalcachefile <- fromRepo gitAnnexInodeSentinalCache
+	liftIO $ writeFile sentinalfile ""
+	liftIO $ maybe noop (writeFile sentinalcachefile . showInodeCache)
+		=<< genInodeCache sentinalfile
+
+{- The sentinal file is only created when first initializing a repository.
+ - If there are any annexed objects in the repository already, creating
+ - the file would invalidate their inode caches. -}
+createInodeSentinalFile :: Annex ()
+createInodeSentinalFile =
+	unlessM (alreadyexists <||> hasobjects)
+		writeInodeSentinalFile
+  where
+	alreadyexists = isJust <$> readInodeSentinalFile
+	hasobjects = liftIO . doesDirectoryExist =<< fromRepo gitAnnexObjectDir

Annex/Direct.hs

@@ -0,0 +1,373 @@
+{- git-annex direct mode
+ -
+ - Copyright 2012, 2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Annex.Direct where
+
+import Common.Annex
+import qualified Annex
+import qualified Git
+import qualified Git.LsFiles
+import qualified Git.Merge
+import qualified Git.DiffTree as DiffTree
+import qualified Git.Config
+import qualified Git.Ref
+import qualified Git.Branch
+import Git.Sha
+import Git.FilePath
+import Git.Types
+import Config
+import Annex.CatFile
+import qualified Annex.Queue
+import Logs.Location
+import Backend
+import Types.KeySource
+import Annex.Content
+import Annex.Content.Direct
+import Annex.Link
+import Utility.InodeCache
+import Utility.CopyFile
+import Annex.Perms
+import Annex.ReplaceFile
+import Annex.Exception
+import Annex.VariantFile
+
+{- Uses git ls-files to find files that need to be committed, and stages
+ - them into the index. Returns True if some changes were staged. -}
+stageDirect :: Annex Bool
+stageDirect = do
+	Annex.Queue.flush
+	top <- fromRepo Git.repoPath
+	(l, cleanup) <- inRepo $ Git.LsFiles.stagedOthersDetails [top]
+	forM_ l go
+	void $ liftIO cleanup
+	staged <- Annex.Queue.size
+	Annex.Queue.flush
+	return $ staged /= 0
+  where
+	{- Determine what kind of modified or deleted file this is, as
+	 - efficiently as we can, by getting any key that's associated
+	 - with it in git, as well as its stat info. -}
+	go (file, Just sha, Just mode) = do
+		shakey <- catKey sha mode
+		mstat <- liftIO $ catchMaybeIO $ getSymbolicLinkStatus file
+		filekey <- isAnnexLink file
+		case (shakey, filekey, mstat, toInodeCache =<< mstat) of
+			(_, Just key, _, _)
+				| shakey == filekey -> noop
+				{- A changed symlink. -}
+				| otherwise -> stageannexlink file key
+			(Just key, _, _, Just cache) -> do
+				{- All direct mode files will show as
+				 - modified, so compare the cache to see if
+				 - it really was. -}
+				oldcache <- recordedInodeCache key
+				case oldcache of
+					[] -> modifiedannexed file key cache
+					_ -> unlessM (elemInodeCaches cache oldcache) $
+						modifiedannexed file key cache
+			(Just key, _, Nothing, _) -> deletedannexed file key
+			(Nothing, _, Nothing, _) -> deletegit file
+			(_, _, Just _, _) -> addgit file
+	go _ = noop
+
+	modifiedannexed file oldkey cache = do
+		void $ removeAssociatedFile oldkey file
+		void $ addDirect file cache
+	
+	deletedannexed file key = do
+		void $ removeAssociatedFile key file
+		deletegit file
+	
+	stageannexlink file key = do
+		l <- inRepo $ gitAnnexLink file key
+		stageSymlink file =<< hashSymlink l
+		void $ addAssociatedFile key file
+
+	addgit file = Annex.Queue.addCommand "add" [Param "-f"] [file]
+
+	deletegit file = Annex.Queue.addCommand "rm" [Param "-qf"] [file]
+
+{- Run before a commit to update direct mode bookeeping to reflect the
+ - staged changes being committed. -}
+preCommitDirect :: Annex Bool
+preCommitDirect = do
+	(diffs, clean) <- inRepo $ DiffTree.diffIndex Git.Ref.headRef
+	makeabs <- flip fromTopFilePath <$> gitRepo
+	forM_ diffs (go makeabs)
+	liftIO clean
+  where
+	go makeabs diff = do
+		withkey (DiffTree.srcsha diff) (DiffTree.srcmode diff) removeAssociatedFile
+		withkey (DiffTree.dstsha diff) (DiffTree.dstmode diff) addAssociatedFile
+	  where
+		withkey sha mode a = when (sha /= nullSha) $ do
+			k <- catKey sha mode
+			case k of
+				Nothing -> noop
+				Just key -> void $ a key $
+					makeabs $ DiffTree.file diff
+
+{- Adds a file to the annex in direct mode. Can fail, if the file is
+ - modified or deleted while it's being added. -}
+addDirect :: FilePath -> InodeCache -> Annex Bool
+addDirect file cache = do
+	showStart "add" file
+	let source = KeySource
+		{ keyFilename = file
+		, contentLocation = file
+		, inodeCache = Just cache
+		}
+	got =<< genKey source =<< chooseBackend file
+  where
+	got Nothing = do
+		showEndFail
+		return False
+	got (Just (key, _)) = ifM (sameInodeCache file [cache])
+		( do
+			l <- inRepo $ gitAnnexLink file key
+			stageSymlink file =<< hashSymlink l
+			addInodeCache key cache
+			void $ addAssociatedFile key file
+			logStatus key InfoPresent
+			showEndOk
+			return True
+		, do
+			showEndFail
+			return False
+		)
+
+{- In direct mode, git merge would usually refuse to do anything, since it
+ - sees present direct mode files as type changed files. To avoid this,
+ - merge is run with the work tree set to a temp directory.
+ -}
+mergeDirect :: FilePath -> Git.Ref -> Git.Repo -> IO Bool
+mergeDirect d branch g = do
+	whenM (doesDirectoryExist d) $
+		removeDirectoryRecursive d
+	createDirectoryIfMissing True d
+	let g' = g { location = Local { gitdir = Git.localGitDir g, worktree = Just d } }
+	Git.Merge.mergeNonInteractive branch g'
+
+{- Cleans up after a direct mode merge. The merge must have been committed,
+ - and the commit sha passed in, along with the old sha of the tree
+ - before the merge. Uses git diff-tree to find files that changed between
+ - the two shas, and applies those changes to the work tree.
+ -
+ - There are really only two types of changes: An old item can be deleted,
+ - or a new item added. Two passes are made, first deleting and then
+ - adding. This is to handle cases where eg, a file is deleted and a
+ - directory is added. (The diff-tree output may list these in the opposite
+ - order, but we cannot add the directory until the file with the
+ - same name is removed.)
+ -}
+mergeDirectCleanup :: FilePath -> Git.Ref -> Git.Ref -> Annex ()
+mergeDirectCleanup d oldsha newsha = do
+	(items, cleanup) <- inRepo $ DiffTree.diffTreeRecursive oldsha newsha
+	makeabs <- flip fromTopFilePath <$> gitRepo
+	let fsitems = zip (map (makeabs . DiffTree.file) items) items
+	forM_ fsitems $
+		go makeabs DiffTree.srcsha DiffTree.srcmode moveout moveout_raw
+	forM_ fsitems $
+		go makeabs DiffTree.dstsha DiffTree.dstmode movein movein_raw
+	void $ liftIO cleanup
+	liftIO $ removeDirectoryRecursive d
+  where
+	go makeabs getsha getmode a araw (f, item)
+		| getsha item == nullSha = noop
+		| otherwise = void $
+			tryAnnex . maybe (araw item makeabs f) (\k -> void $ a item makeabs k f)
+				=<< catKey (getsha item) (getmode item)
+
+	moveout _ _ = removeDirect
+
+	{- Files deleted by the merge are removed from the work tree.
+	 - Empty work tree directories are removed, per git behavior. -}
+	moveout_raw _ _ f = liftIO $ do
+		nukeFile f
+		void $ tryIO $ removeDirectory $ parentDir f
+	
+	{- If the file is already present, with the right content for the
+	 - key, it's left alone. 
+	 -
+	 - If the file is already present, and does not exist in the
+	 - oldsha branch, preserve this local file.
+	 -
+	 - Otherwise, create the symlink and then if possible, replace it
+	 - with the content. -}
+	movein item makeabs k f = unlessM (goodContent k f) $ do
+		preserveUnannexed item makeabs f oldsha
+		l <- inRepo $ gitAnnexLink f k
+		replaceFile f $ makeAnnexLink l
+		toDirect k f
+	
+	{- Any new, modified, or renamed files were written to the temp
+	 - directory by the merge, and are moved to the real work tree. -}
+	movein_raw item makeabs f = do
+		preserveUnannexed item makeabs f oldsha
+		liftIO $ do
+			createDirectoryIfMissing True $ parentDir f
+			void $ tryIO $ rename (d </> getTopFilePath (DiffTree.file item)) f
+
+{- If the file that's being moved in is already present in the work
+ - tree, but did not exist in the oldsha branch, preserve this
+ - local, unannexed file (or directory), as "variant-local".
+ -
+ - It's also possible that the file that's being moved in
+ - is in a directory that collides with an exsting, non-annexed
+ - file (not a directory), which should be preserved.
+ -}
+preserveUnannexed :: DiffTree.DiffTreeItem -> (TopFilePath -> FilePath) -> FilePath -> Ref -> Annex ()
+preserveUnannexed item makeabs absf oldsha = do
+	whenM (liftIO (collidingitem absf) <&&> unannexed absf) $
+		liftIO $ findnewname absf 0
+	checkdirs (DiffTree.file item)
+  where
+	checkdirs from = do
+		let p = parentDir (getTopFilePath from)
+		let d = asTopFilePath p
+		unless (null p) $ do
+			let absd = makeabs d
+			whenM (liftIO (colliding_nondir absd) <&&> unannexed absd) $
+				liftIO $ findnewname absd 0
+			checkdirs d
+			
+	collidingitem f = isJust
+		<$> catchMaybeIO (getSymbolicLinkStatus f)
+	colliding_nondir f = maybe False (not . isDirectory)
+		<$> catchMaybeIO (getSymbolicLinkStatus f)
+
+	unannexed f = (isNothing <$> isAnnexLink f)
+		<&&> (isNothing <$> catFileDetails oldsha f)
+
+	findnewname :: FilePath -> Int -> IO ()
+	findnewname f n = do
+		let localf = mkVariant f 
+			("local" ++ if n > 0 then show n else "")
+		ifM (collidingitem localf)
+			( findnewname f (n+1)
+			, rename f localf
+				`catchIO` const (findnewname f (n+1))
+			)
+
+{- If possible, converts a symlink in the working tree into a direct
+ - mode file. If the content is not available, leaves the symlink
+ - unchanged. -}
+toDirect :: Key -> FilePath -> Annex ()
+toDirect k f = fromMaybe noop =<< toDirectGen k f
+
+toDirectGen :: Key -> FilePath -> Annex (Maybe (Annex ()))
+toDirectGen k f = do
+	loc <- calcRepo $ gitAnnexLocation k
+	ifM (liftIO $ doesFileExist loc)
+		( return $ Just $ fromindirect loc
+		, do
+			{- Copy content from another direct file. -}
+			absf <- liftIO $ absPath f
+			dlocs <- filterM (goodContent k) =<<
+				filterM (\l -> isNothing <$> getAnnexLinkTarget l) =<<
+				(filter (/= absf) <$> addAssociatedFile k f)
+			case dlocs of
+				[] -> return Nothing
+				(dloc:_) -> return $ Just $ fromdirect dloc
+		)
+  where
+  	fromindirect loc = do
+		{- Move content from annex to direct file. -}
+		updateInodeCache k loc
+		void $ addAssociatedFile k f
+		modifyContent loc $ do
+			thawContent loc
+			replaceFile f $ liftIO . moveFile loc
+	fromdirect loc = do
+		replaceFile f $
+			liftIO . void . copyFileExternal loc
+		updateInodeCache k f
+
+{- Removes a direct mode file, while retaining its content in the annex
+ - (unless its content has already been changed). -}
+removeDirect :: Key -> FilePath -> Annex ()
+removeDirect k f = do
+	void $ removeAssociatedFileUnchecked k f
+	unlessM (inAnnex k) $
+		ifM (goodContent k f)
+			( moveAnnex k f
+			, logStatus k InfoMissing
+			)
+	liftIO $ do
+		nukeFile f
+		void $ tryIO $ removeDirectory $ parentDir f
+
+{- Called when a direct mode file has been changed. Its old content may be
+ - lost. -}
+changedDirect :: Key -> FilePath -> Annex ()
+changedDirect oldk f = do
+	locs <- removeAssociatedFile oldk f
+	whenM (pure (null locs) <&&> not <$> inAnnex oldk) $
+		logStatus oldk InfoMissing
+
+{- Enable/disable direct mode. -}
+setDirect :: Bool -> Annex ()
+setDirect wantdirect = do
+	if wantdirect
+		then do
+			switchHEAD
+			setbare
+		else do
+			setbare
+			switchHEADBack
+	setConfig (annexConfig "direct") val
+	Annex.changeGitConfig $ \c -> c { annexDirect = wantdirect }
+  where
+	val = Git.Config.boolConfig wantdirect
+	setbare = setConfig (ConfigKey Git.Config.coreBare) val
+
+{- Since direct mode sets core.bare=true, incoming pushes could change
+ - the currently checked out branch. To avoid this problem, HEAD
+ - is changed to a internal ref that nothing is going to push to.
+ -
+ - For refs/heads/master, use refs/heads/annex/direct/master;
+ - this way things that show HEAD (eg shell prompts) will
+ - hopefully show just "master". -}
+directBranch :: Ref -> Ref
+directBranch orighead = case split "/" $ fromRef orighead of
+	("refs":"heads":"annex":"direct":_) -> orighead
+	("refs":"heads":rest) ->
+		Ref $ "refs/heads/annex/direct/" ++ intercalate "/" rest
+	_ -> Ref $ "refs/heads/" ++ fromRef (Git.Ref.base orighead)
+
+{- Converts a directBranch back to the original branch.
+ -
+ - Any other ref is left unchanged.
+ -}
+fromDirectBranch :: Ref -> Ref
+fromDirectBranch directhead = case split "/" $ fromRef directhead of
+	("refs":"heads":"annex":"direct":rest) -> 
+		Ref $ "refs/heads/" ++ intercalate "/" rest
+	_ -> directhead
+
+switchHEAD :: Annex ()
+switchHEAD = maybe noop switch =<< inRepo Git.Branch.currentUnsafe
+  where
+	switch orighead = do
+		let newhead = directBranch orighead
+		maybe noop (inRepo . Git.Branch.update newhead)
+			=<< inRepo (Git.Ref.sha orighead)
+		inRepo $ Git.Branch.checkout newhead
+
+switchHEADBack :: Annex ()
+switchHEADBack = maybe noop switch =<< inRepo Git.Branch.currentUnsafe
+  where
+	switch currhead = do
+		let orighead = fromDirectBranch currhead
+		v <- inRepo $ Git.Ref.sha currhead
+		case v of
+			Just headsha
+				| orighead /= currhead -> do
+					inRepo $ Git.Branch.update orighead headsha
+					inRepo $ Git.Branch.checkout orighead
+					inRepo $ Git.Branch.delete currhead
+			_ -> inRepo $ Git.Branch.checkout orighead

Annex/Direct/Fixup.hs

@@ -0,0 +1,31 @@
+{- git-annex direct mode guard fixup
+ -
+ - Copyright 2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Annex.Direct.Fixup where
+
+import Git.Types
+import Git.Config
+import qualified Git.Construct as Construct
+import Utility.Path
+import Utility.SafeCommand
+
+{- Direct mode repos have core.bare=true, but are not really bare.
+ - Fix up the Repo to be a non-bare repo, and arrange for git commands
+ - run by git-annex to be passed parameters that override this setting. -}
+fixupDirect :: Repo -> IO Repo
+fixupDirect r@(Repo { location = l@(Local { gitdir = d, worktree = Nothing }) }) = do
+	let r' = r
+		{ location = l { worktree = Just (parentDir d) }
+		, gitGlobalOpts = gitGlobalOpts r ++
+			[ Param "-c"
+			, Param $ coreBare ++ "=" ++ boolConfig False
+			]
+		}
+	-- Recalc now that the worktree is correct.
+	rs' <- Construct.fromRemotes r'
+	return $ r' { remotes = rs' }
+fixupDirect r = return r

Annex/Drop.hs

@@ -0,0 +1,124 @@
+{- dropping of unwanted content
+ -
+ - Copyright 2012-2014 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Annex.Drop where
+
+import Common.Annex
+import Logs.Trust
+import Config.NumCopies
+import Types.Remote (uuid)
+import Types.Key (key2file)
+import qualified Remote
+import qualified Command.Drop
+import Command
+import Annex.Wanted
+import Annex.Exception
+import Config
+import Annex.Content.Direct
+
+import qualified Data.Set as S
+import System.Log.Logger (debugM)
+
+type Reason = String
+
+{- Drop a key from local and/or remote when allowed by the preferred content
+ - and numcopies settings.
+ -
+ - The UUIDs are ones where the content is believed to be present.
+ - The Remote list can include other remotes that do not have the content;
+ - only ones that match the UUIDs will be dropped from.
+ - If allowed to drop fromhere, that drop will be tried first.
+ -
+ - A remote can be specified that is known to have the key. This can be
+ - used an an optimisation when eg, a key has just been uploaded to a
+ - remote.
+ -
+ - In direct mode, all associated files are checked, and only if all
+ - of them are unwanted are they dropped.
+ -
+ - The runner is used to run commands, and so can be either callCommand
+ - or commandAction.
+ -}
+handleDropsFrom :: [UUID] -> [Remote] -> Reason -> Bool -> Key -> AssociatedFile -> Maybe Remote -> CommandActionRunner -> Annex ()
+handleDropsFrom locs rs reason fromhere key afile knownpresentremote runner = do
+	fs <- ifM isDirect
+		( do
+			l <- associatedFilesRelative key
+			return $ if null l
+				then maybeToList afile
+				else l
+		, return $ maybeToList afile
+		)
+	n <- getcopies fs
+	if fromhere && checkcopies n Nothing
+		then go fs rs =<< dropl fs n
+		else go fs rs n
+  where
+	getcopies fs = do
+		(untrusted, have) <- trustPartition UnTrusted locs
+		numcopies <- if null fs
+			then getNumCopies
+			else maximum <$> mapM getFileNumCopies fs
+		return (NumCopies (length have), numcopies, S.fromList untrusted)
+
+	{- Check that we have enough copies still to drop the content.
+	 - When the remote being dropped from is untrusted, it was not
+	 - counted as a copy, so having only numcopies suffices. Otherwise,
+	 - we need more than numcopies to safely drop. -}
+	checkcopies (have, numcopies, _untrusted) Nothing = have > numcopies
+	checkcopies (have, numcopies, untrusted) (Just u)
+		| S.member u untrusted = have >= numcopies
+		| otherwise = have > numcopies
+	
+	decrcopies (have, numcopies, untrusted) Nothing =
+		(NumCopies (fromNumCopies have - 1), numcopies, untrusted)
+	decrcopies v@(_have, _numcopies, untrusted) (Just u)
+		| S.member u untrusted = v
+		| otherwise = decrcopies v Nothing
+
+	go _ [] _ = noop
+	go fs (r:rest) n
+		| uuid r `S.notMember` slocs = go fs rest n
+		| checkcopies n (Just $ Remote.uuid r) =
+			dropr fs r n >>= go fs rest
+		| otherwise = noop
+
+	checkdrop fs n u a
+		| null fs = check $ -- no associated files; unused content
+			wantDrop True u (Just key) Nothing
+		| otherwise = check $
+			allM (wantDrop True u (Just key) . Just) fs
+		where
+			check c = ifM c
+				( dodrop n u a
+				, return n
+				)
+
+	dodrop n@(have, numcopies, _untrusted) u a = 
+		ifM (safely $ runner $ a numcopies)
+			( do
+				liftIO $ debugM "drop" $ unwords
+					[ "dropped"
+					, fromMaybe (key2file key) afile
+					, "(from " ++ maybe "here" show u ++ ")"
+					, "(copies now " ++ show (fromNumCopies have - 1) ++ ")"
+					, ": " ++ reason
+					]
+				return $ decrcopies n u
+			, return n
+			)
+
+	dropl fs n = checkdrop fs n Nothing $ \numcopies ->
+		Command.Drop.startLocal afile numcopies key knownpresentremote
+
+	dropr fs r n  = checkdrop fs n (Just $ Remote.uuid r) $ \numcopies ->
+		Command.Drop.startRemote afile numcopies key r
+
+	slocs = S.fromList locs
+	
+	safely a = either (const False) id <$> tryAnnex a
+

Annex/Environment.hs

@@ -0,0 +1,65 @@
+{- git-annex environment
+ -
+ - Copyright 2012, 2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE CPP #-}
+
+module Annex.Environment where
+
+import Common.Annex
+import Utility.UserInfo
+import qualified Git.Config
+import Config
+import Annex.Exception
+
+#ifndef mingw32_HOST_OS
+import Utility.Env
+#endif
+
+{- Checks that the system's environment allows git to function.
+ - Git requires a GECOS username, or suitable git configuration, or
+ - environment variables.
+ -
+ - Git also requires the system have a hostname containing a dot.
+ - Otherwise, it tries various methods to find a FQDN, and will fail if it
+ - does not. To avoid replicating that code here, which would break if its
+ - methods change, this function does not check the hostname is valid.
+ - Instead, code that commits can use ensureCommit.
+ -}
+checkEnvironment :: Annex ()
+checkEnvironment = do
+	gitusername <- fromRepo $ Git.Config.getMaybe "user.name"
+	when (isNothing gitusername || gitusername == Just "") $
+		liftIO checkEnvironmentIO
+
+checkEnvironmentIO :: IO ()
+checkEnvironmentIO =
+#ifdef mingw32_HOST_OS
+	noop
+#else
+	whenM (null <$> myUserGecos) $ do
+		username <- myUserName
+		ensureEnv "GIT_AUTHOR_NAME" username
+		ensureEnv "GIT_COMMITTER_NAME" username
+  where
+#ifndef __ANDROID__
+  	-- existing environment is not overwritten
+	ensureEnv var val = void $ setEnv var val False
+#else
+	-- Environment setting is broken on Android, so this is dealt with
+	-- in runshell instead.
+	ensureEnv _ _ = noop
+#endif
+#endif
+
+{- Runs an action that commits to the repository, and if it fails, 
+ - sets user.email to a dummy value and tries the action again. -}
+ensureCommit :: Annex a -> Annex a
+ensureCommit a = either retry return =<< tryAnnex a 
+  where
+  	retry _ = do
+		setConfig (ConfigKey "user.email") =<< liftIO myUserName
+		a

Annex/Exception.hs

@@ -0,0 +1,50 @@
+{- exception handling in the git-annex monad
+ -
+ - Note that when an Annex action fails and the exception is handled
+ - by these functions, any changes the action has made to the
+ - AnnexState are retained. This works because the Annex monad
+ - internally stores the AnnexState in a MVar.
+ -
+ - Copyright 2011-2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE PackageImports #-}
+
+module Annex.Exception (
+	bracketIO,
+	bracketAnnex,
+	tryAnnex,
+	tryAnnexIO,
+	throwAnnex,
+	catchAnnex,
+) where
+
+import qualified "MonadCatchIO-transformers" Control.Monad.CatchIO as M
+import Control.Exception
+
+import Common.Annex
+
+{- Runs an Annex action, with setup and cleanup both in the IO monad. -}
+bracketIO :: IO v -> (v -> IO b) -> (v -> Annex a) -> Annex a
+bracketIO setup cleanup = M.bracket (liftIO setup) (liftIO . cleanup)
+
+bracketAnnex :: Annex v -> (v -> Annex b) -> (v -> Annex a) -> Annex a
+bracketAnnex = M.bracket
+
+{- try in the Annex monad -}
+tryAnnex :: Annex a -> Annex (Either SomeException a)
+tryAnnex = M.try
+
+{- try in the Annex monad, but only catching IO exceptions -}
+tryAnnexIO :: Annex a -> Annex (Either IOException a)
+tryAnnexIO = M.try
+
+{- throw in the Annex monad -}
+throwAnnex :: Exception e => e -> Annex a
+throwAnnex = M.throw
+
+{- catch in the Annex monad -}
+catchAnnex :: Exception e => Annex a -> (e -> Annex a) -> Annex a
+catchAnnex = M.catch

Annex/FileMatcher.hs

@@ -0,0 +1,116 @@
+{- git-annex file matching
+ -
+ - Copyright 2012-2014 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Annex.FileMatcher where
+
+import qualified Data.Map as M
+
+import Common.Annex
+import Limit
+import Utility.Matcher
+import Types.Group
+import Logs.Group
+import Logs.Remote
+import Annex.UUID
+import qualified Annex
+import Types.FileMatcher
+import Git.FilePath
+import Types.Remote (RemoteConfig)
+
+import Data.Either
+import qualified Data.Set as S
+
+checkFileMatcher :: (FileMatcher Annex) -> FilePath -> Annex Bool
+checkFileMatcher matcher file = checkMatcher matcher Nothing (Just file) S.empty True
+
+checkMatcher :: (FileMatcher Annex) -> Maybe Key -> AssociatedFile -> AssumeNotPresent -> Bool -> Annex Bool
+checkMatcher matcher mkey afile notpresent def
+	| isEmpty matcher = return def
+	| otherwise = case (mkey, afile) of
+		(_, Just file) -> go =<< fileMatchInfo file
+		(Just key, _) -> go (MatchingKey key)
+		_ -> return def
+  where
+	go mi = matchMrun matcher $ \a -> a notpresent mi
+
+fileMatchInfo :: FilePath -> Annex MatchInfo
+fileMatchInfo file = do
+	matchfile <- getTopFilePath <$> inRepo (toTopFilePath file)
+	return $ MatchingFile FileInfo
+		{ matchFile = matchfile
+		, relFile = file
+		}
+
+matchAll :: FileMatcher Annex
+matchAll = generate []
+
+parsedToMatcher :: [Either String (Token (MatchFiles Annex))] -> Either String (FileMatcher Annex)
+parsedToMatcher parsed = case partitionEithers parsed of
+	([], vs) -> Right $ generate vs
+	(es, _) -> Left $ unwords $ map ("Parse failure: " ++) es
+
+exprParser :: FileMatcher Annex -> FileMatcher Annex -> GroupMap -> M.Map UUID RemoteConfig -> Maybe UUID -> String -> [Either String (Token (MatchFiles Annex))]
+exprParser matchstandard matchgroupwanted groupmap configmap mu expr =
+	map parse $ tokenizeMatcher expr
+  where
+	parse = parseToken
+		matchstandard
+		matchgroupwanted
+		(limitPresent mu)
+		(limitInDir preferreddir)
+		groupmap
+	preferreddir = fromMaybe "public" $
+		M.lookup "preferreddir" =<< (`M.lookup` configmap) =<< mu
+
+parseToken :: FileMatcher Annex -> FileMatcher Annex -> MkLimit Annex -> MkLimit Annex -> GroupMap -> String -> Either String (Token (MatchFiles Annex))
+parseToken matchstandard matchgroupwanted checkpresent checkpreferreddir groupmap t
+	| t `elem` tokens = Right $ token t
+	| t == "standard" = call matchstandard
+	| t == "groupwanted" = call matchgroupwanted
+	| t == "present" = use checkpresent
+	| t == "inpreferreddir" = use checkpreferreddir
+	| t == "unused" = Right $ Operation limitUnused
+	| otherwise = maybe (Left $ "near " ++ show t) use $ M.lookup k $
+		M.fromList
+			[ ("include", limitInclude)
+			, ("exclude", limitExclude)
+			, ("copies", limitCopies)
+			, ("lackingcopies", limitLackingCopies False)
+			, ("approxlackingcopies", limitLackingCopies True)
+			, ("inbackend", limitInBackend)
+			, ("largerthan", limitSize (>))
+			, ("smallerthan", limitSize (<))
+			, ("metadata", limitMetaData)
+			, ("inallgroup", limitInAllGroup groupmap)
+			]
+  where
+	(k, v) = separate (== '=') t
+	use a = Operation <$> a v
+	call sub = Right $ Operation $ \notpresent mi ->
+		matchMrun sub $ \a -> a notpresent mi
+
+{- This is really dumb tokenization; there's no support for quoted values.
+ - Open and close parens are always treated as standalone tokens;
+ - otherwise tokens must be separated by whitespace. -}
+tokenizeMatcher :: String -> [String]
+tokenizeMatcher = filter (not . null ) . concatMap splitparens . words
+  where
+	splitparens = segmentDelim (`elem` "()")
+
+{- Generates a matcher for files large enough (or meeting other criteria)
+ - to be added to the annex, rather than directly to git. -}
+largeFilesMatcher :: Annex (FileMatcher Annex)
+largeFilesMatcher = go =<< annexLargeFiles <$> Annex.getGitConfig
+  where
+  	go Nothing = return matchAll
+	go (Just expr) = do
+		gm <- groupMap
+		rc <- readRemoteLog
+		u <- getUUID
+		either badexpr return $
+			parsedToMatcher $ exprParser matchAll matchAll gm rc (Just u) expr
+	badexpr e = error $ "bad annex.largefiles configuration: " ++ e

Annex/Hook.hs

@@ -0,0 +1,71 @@
+{- git-annex git hooks
+ -
+ - Note that it's important that the scripts installed by git-annex
+ - not change, otherwise removing old hooks using an old version of
+ - the script would fail.
+ -
+ - Copyright 2013-2014 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Annex.Hook where
+
+import Common.Annex
+import qualified Git.Hook as Git
+import Config
+import qualified Annex
+import Utility.Shell
+import Utility.FileMode
+
+import qualified Data.Map as M
+
+preCommitHook :: Git.Hook
+preCommitHook = Git.Hook "pre-commit" (mkHookScript "git annex pre-commit .")
+
+preCommitAnnexHook :: Git.Hook
+preCommitAnnexHook = Git.Hook "pre-commit-annex" ""
+
+mkHookScript :: String -> String
+mkHookScript s = unlines
+	[ shebang_local
+	, "# automatically configured by git-annex"
+	, s
+	]
+
+hookWrite :: Git.Hook -> Annex ()
+hookWrite h = 
+	-- cannot have git hooks in a crippled filesystem (no execute bit)
+	unlessM crippledFileSystem $
+		unlessM (inRepo $ Git.hookWrite h) $
+			hookWarning h "already exists, not configuring"
+
+hookUnWrite :: Git.Hook -> Annex ()
+hookUnWrite h = unlessM (inRepo $ Git.hookUnWrite h) $
+	hookWarning h "contents modified; not deleting. Edit it to remove call to git annex."
+
+hookWarning :: Git.Hook -> String -> Annex ()
+hookWarning h msg = do
+	r <- gitRepo
+	warning $ Git.hookName h ++ " hook (" ++ Git.hookFile h r ++ ") " ++ msg
+
+{- Runs a hook. To avoid checking if the hook exists every time,
+ - the existing hooks are cached. -}
+runAnnexHook :: Git.Hook -> Annex ()
+runAnnexHook hook = do
+	cmd <- fromRepo $ Git.hookFile hook
+	m <- Annex.getState Annex.existinghooks
+	case M.lookup hook m of
+		Just True -> run cmd
+		Just False -> noop
+		Nothing -> do
+			exists <- hookexists cmd
+			Annex.changeState $ \s -> s
+				{ Annex.existinghooks = M.insert hook exists m }
+			when exists $
+				run cmd
+  where
+	hookexists f = liftIO $ catchBoolIO $
+		isExecutable . fileMode <$> getFileStatus f
+	run cmd = unlessM (liftIO $ boolSystem cmd []) $
+		warning $ cmd ++ " failed"

Annex/Index.hs

@@ -0,0 +1,46 @@
+{- Using other git index files
+ -
+ - Copyright 2014 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE CPP #-}
+
+module Annex.Index (
+	withIndexFile,
+) where
+
+import qualified Control.Exception as E
+
+import Common.Annex
+import Git.Types
+import qualified Annex
+import Utility.Env
+import Annex.Exception
+
+{- Runs an action using a different git index file. -}
+withIndexFile :: FilePath -> Annex a -> Annex a
+withIndexFile f a = do
+	g <- gitRepo
+#ifdef __ANDROID__
+	{- This should not be necessary on Android, but there is some
+	 - weird getEnvironment breakage. See
+	 - https://github.com/neurocyte/ghc-android/issues/7
+	 - Use getEnv to get some key environment variables that
+	 - git expects to have. -}
+	let keyenv = words "USER PATH GIT_EXEC_PATH HOSTNAME HOME"
+	let getEnvPair k = maybe Nothing (\v -> Just (k, v)) <$> getEnv k
+	e <- liftIO $ catMaybes <$> forM keyenv getEnvPair
+	let e' = ("GIT_INDEX_FILE", f):e
+#else
+	e <- liftIO getEnvironment
+	let e' = addEntry "GIT_INDEX_FILE" f e
+#endif
+	let g' = g { gitEnv = Just e' }
+
+	r <- tryAnnex $ do
+		Annex.changeState $ \s -> s { Annex.repo = g' }
+		a
+	Annex.changeState $ \s -> s { Annex.repo = (Annex.repo s) { gitEnv = gitEnv g} }
+	either E.throw return r

Annex/Init.hs

@@ -0,0 +1,239 @@
+{- git-annex repository initialization
+ -
+ - Copyright 2011 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE CPP #-}
+
+module Annex.Init (
+	ensureInitialized,
+	isInitialized,
+	initialize,
+	uninitialize,
+	probeCrippledFileSystem,
+) where
+
+import Common.Annex
+import Utility.Network
+import qualified Annex
+import qualified Git
+import qualified Git.LsFiles
+import qualified Git.Config
+import qualified Git.Construct
+import qualified Git.Types as Git
+import qualified Annex.Branch
+import Logs.UUID
+import Annex.Version
+import Annex.UUID
+import Config
+import Annex.Direct
+import Annex.Content.Direct
+import Annex.Environment
+import Annex.Perms
+import Backend
+#ifndef mingw32_HOST_OS
+import Utility.UserInfo
+import Utility.FileMode
+#endif
+import Annex.Hook
+import Git.Hook (hookFile)
+import Upgrade
+import Annex.Content
+import Logs.Location
+
+import System.Log.Logger
+
+genDescription :: Maybe String -> Annex String
+genDescription (Just d) = return d
+genDescription Nothing = do
+	reldir <- liftIO . relHome =<< fromRepo Git.repoPath
+	hostname <- fromMaybe "" <$> liftIO getHostname
+#ifndef mingw32_HOST_OS
+	let at = if null hostname then "" else "@"
+	username <- liftIO myUserName
+	return $ concat [username, at, hostname, ":", reldir]
+#else
+	return $ concat [hostname, ":", reldir]
+#endif
+
+initialize :: Maybe String -> Annex ()
+initialize mdescription = do
+	prepUUID
+	checkFifoSupport
+	checkCrippledFileSystem
+	unlessM isBare $
+		hookWrite preCommitHook
+	setVersion supportedVersion
+	ifM (crippledFileSystem <&&> not <$> isBare)
+		( do
+			enableDirectMode
+			setDirect True
+		-- Handle case where this repo was cloned from a
+		-- direct mode repo
+		, unlessM isBare
+			switchHEADBack
+		)
+	createInodeSentinalFile
+	u <- getUUID
+	{- This will make the first commit to git, so ensure git is set up
+	 - properly to allow commits when running it. -}
+	ensureCommit $ do
+		Annex.Branch.create
+		describeUUID u =<< genDescription mdescription
+
+uninitialize :: Annex ()
+uninitialize = do
+	hookUnWrite preCommitHook
+	removeRepoUUID
+	removeVersion
+
+{- Will automatically initialize if there is already a git-annex
+ - branch from somewhere. Otherwise, require a manual init
+ - to avoid git-annex accidentially being run in git
+ - repos that did not intend to use it.
+ -
+ - Checks repository version and handles upgrades too.
+ -}
+ensureInitialized :: Annex ()
+ensureInitialized = do
+	getVersion >>= maybe needsinit checkUpgrade
+	fixBadBare
+  where
+	needsinit = ifM Annex.Branch.hasSibling
+			( initialize Nothing
+			, error "First run: git-annex init"
+			)
+
+{- Checks if a repository is initialized. Does not check version for ugrade. -}
+isInitialized :: Annex Bool
+isInitialized = maybe Annex.Branch.hasSibling (const $ return True) =<< getVersion
+
+isBare :: Annex Bool
+isBare = fromRepo Git.repoIsLocalBare
+
+{- A crippled filesystem is one that does not allow making symlinks,
+ - or removing write access from files. -}
+probeCrippledFileSystem :: Annex Bool
+probeCrippledFileSystem = do
+#ifdef mingw32_HOST_OS
+	return True
+#else
+	tmp <- fromRepo gitAnnexTmpMiscDir
+	let f = tmp </> "gaprobe"
+	createAnnexDirectory tmp
+	liftIO $ writeFile f ""
+	uncrippled <- liftIO $ probe f
+	liftIO $ removeFile f
+	return $ not uncrippled
+  where
+	probe f = catchBoolIO $ do
+		let f2 = f ++ "2"
+		nukeFile f2
+		createSymbolicLink f f2
+		nukeFile f2
+		preventWrite f
+		allowWrite f
+		return True
+#endif
+
+checkCrippledFileSystem :: Annex ()
+checkCrippledFileSystem = whenM probeCrippledFileSystem $ do
+	warning "Detected a crippled filesystem."
+	setCrippledFileSystem True
+
+	{- Normally git disables core.symlinks itself when the
+	 - filesystem does not support them, but in Cygwin, git
+	 - does support symlinks, while git-annex, not linking
+	 - with Cygwin, does not. -}
+	whenM (coreSymlinks <$> Annex.getGitConfig) $ do
+		warning "Disabling core.symlinks."
+		setConfig (ConfigKey "core.symlinks")
+			(Git.Config.boolConfig False)
+
+probeFifoSupport :: Annex Bool
+probeFifoSupport = do
+#ifdef mingw32_HOST_OS
+	return False
+#else
+	tmp <- fromRepo gitAnnexTmpMiscDir
+	let f = tmp </> "gaprobe"
+	createAnnexDirectory tmp
+	liftIO $ do
+		nukeFile f
+		ms <- tryIO $ do
+			createNamedPipe f ownerReadMode
+			getFileStatus f
+		nukeFile f
+		return $ either (const False) isNamedPipe ms
+#endif
+
+checkFifoSupport :: Annex ()
+checkFifoSupport = unlessM probeFifoSupport $ do
+	warning "Detected a filesystem without fifo support."
+	warning "Disabling ssh connection caching."
+	setConfig (annexConfig "sshcaching") (Git.Config.boolConfig False)
+
+enableDirectMode :: Annex ()
+enableDirectMode = unlessM isDirect $ do
+	warning "Enabling direct mode."
+	top <- fromRepo Git.repoPath
+	(l, clean) <- inRepo $ Git.LsFiles.inRepo [top]
+	forM_ l $ \f ->
+		maybe noop (`toDirect` f) =<< isAnnexLink f
+	void $ liftIO clean
+
+{- Work around for git-annex version 5.20131118 - 5.20131127, which
+ - had a bug that unset core.bare when initializing a bare repository.
+ - 
+ - This resulted in objects sent to the repository being stored in 
+ - repo/.git/annex/objects, so move them to repo/annex/objects.
+ -
+ - This check slows down every git-annex run somewhat (by one file stat),
+ - so should be removed after a suitable period of time has passed.
+ - Since the bare repository may be on an offline USB drive, best to
+ - keep it for a while. However, git-annex was only buggy for a few
+ - weeks, so not too long.
+ -}
+fixBadBare :: Annex ()
+fixBadBare = whenM checkBadBare $ do
+	ks <- getKeysPresent InAnnex
+	liftIO $ debugM "Init" $ unwords
+		[ "Detected bad bare repository with"
+		, show (length ks)
+		, "objects; fixing"
+		]
+	g <- Annex.gitRepo
+	gc <- Annex.getGitConfig
+	d <- Git.repoPath <$> Annex.gitRepo
+	void $ liftIO $ boolSystem "git"
+		[ Param $ "--git-dir=" ++ d
+		, Param "config"
+		, Param Git.Config.coreBare
+		, Param $ Git.Config.boolConfig True
+		]
+	g' <- liftIO $ Git.Construct.fromPath d
+	s' <- liftIO $ Annex.new $ g' { Git.location = Git.Local { Git.gitdir = d, Git.worktree = Nothing } }
+	Annex.changeState $ \s -> s
+		{ Annex.repo = Annex.repo s'
+		, Annex.gitconfig = Annex.gitconfig s'
+		}
+	forM_ ks $ \k -> do
+		oldloc <- liftIO $ gitAnnexLocation k g gc
+		thawContentDir oldloc
+		moveAnnex k oldloc
+		logStatus k InfoPresent
+	let dotgit = d </> ".git"
+	liftIO $ removeDirectoryRecursive dotgit
+		`catchIO` const (renameDirectory dotgit (d </> "removeme"))
+
+{- A repostory with the problem won't know it's a bare repository, but will
+ - have no pre-commit hook (which is not set up in a bare repository),
+ - and will not have a HEAD file in its .git directory. -}
+checkBadBare :: Annex Bool
+checkBadBare = allM (not <$>)
+	[isBare, hasPreCommitHook, hasDotGitHEAD]
+  where
+	hasPreCommitHook = inRepo $ doesFileExist . hookFile preCommitHook
+	hasDotGitHEAD = inRepo $ \r -> doesFileExist $ Git.localGitDir r </> "HEAD"

Annex/Journal.hs

@@ -0,0 +1,127 @@
+{- 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 System.IO.Binary
+
+import Common.Annex
+import Annex.Exception
+import qualified Git
+import Annex.Perms
+
+#ifdef mingw32_HOST_OS
+import Utility.WinLock
+#endif
+
+{- 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
+		writeBinaryFile tmpfile 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 $
+	readFileStrict $ 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
+
+{- Checks if there are changes in the journal. -}
+journalDirty :: Annex Bool
+journalDirty = not . null <$> getJournalFilesStale
+
+{- 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 = do
+	lockfile <- fromRepo gitAnnexJournalLock
+	createAnnexDirectory $ takeDirectory lockfile
+	mode <- annexFileMode
+	bracketIO (lock lockfile mode) unlock (const $ a ProduceJournalLocked)
+  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

Annex/Link.hs

@@ -0,0 +1,105 @@
+{- 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
+
+{- 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.
+ -}
+makeAnnexLink :: LinkTarget -> FilePath -> Annex ()
+makeAnnexLink 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)

Annex/LockPool.hs

@@ -0,0 +1,60 @@
+{- git-annex lock pool
+ -
+ - Copyright 2012, 2014 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE CPP #-}
+
+module Annex.LockPool where
+
+import Common.Annex
+import Annex
+import Types.LockPool
+
+import qualified Data.Map as M
+
+#ifndef mingw32_HOST_OS
+import Annex.Perms
+#else
+import Utility.WinLock
+#endif
+
+{- Create a specified lock file, and takes a shared lock. -}
+lockFile :: FilePath -> Annex ()
+lockFile file = go =<< fromPool 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
+		changePool $ M.insert file lockhandle
+
+unlockFile :: FilePath -> Annex ()
+unlockFile file = maybe noop go =<< fromPool file
+  where
+	go lockhandle = do
+#ifndef mingw32_HOST_OS
+		liftIO $ closeFd lockhandle
+#else
+		liftIO $ dropLock lockhandle
+#endif
+		changePool $ M.delete file
+
+getPool :: Annex LockPool
+getPool = getState lockpool
+
+fromPool :: FilePath -> Annex (Maybe LockHandle)
+fromPool file = M.lookup file <$> getPool
+
+changePool :: (LockPool -> LockPool) -> Annex ()
+changePool a = do
+	m <- getPool
+	changeState $ \s -> s { lockpool = a m }

Annex/MetaData.hs

@@ -0,0 +1,56 @@
+{- git-annex metadata
+ -
+ - Copyright 2014 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Annex.MetaData (
+	genMetaData,
+	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
+		metadata <- getCurrentMetaData key
+		let metadata' = genMetaData' status metadata
+		unless (metadata' == emptyMetaData) $
+			addMetaData key metadata'
+
+{- Generates metadata from the FileStatus.
+ - Does not overwrite any existing metadata values. -}
+genMetaData' :: FileStatus -> MetaData -> MetaData
+genMetaData' status 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 $ 
+		posixSecondsToUTCTime $ realToFrac $
+			modificationTime status

Annex/MetaData/StandardFields.hs

@@ -0,0 +1,47 @@
+{- 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"

Annex/Notification.hs

@@ -0,0 +1,81 @@
+{- 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 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
+	let action = if direction == Upload then "uploading" else "downloading"
+	let basedesc = action ++ " " ++ f
+	let startdesc = "started " ++ basedesc
+	let enddesc ok = if ok
+		then "finished " ++ basedesc
+		else basedesc ++ " failed"
+	if (notifyStart wanted || notifyFinish wanted)
+		then do
+			client <- liftIO DBus.Client.connectSession
+			startnotification <- liftIO $ if notifyStart wanted
+				then Just <$> Notify.notify client (mkNote startdesc)
+				else pure Nothing
+			ok <- a NotifyWitness
+			when (notifyFinish wanted) $ liftIO $ void $ maybe 
+				(Notify.notify client $ mkNote $ enddesc ok)
+				(\n -> Notify.replace client n $ mkNote $ enddesc ok)
+				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
+		let msg = if ok
+			then "dropped " ++ f
+			else "failed to drop" ++ f
+		void $ Notify.notify client (mkNote msg)
+#else
+notifyDrop (Just _) _ = noop
+#endif
+
+#ifdef WITH_DBUS_NOTIFICATIONS
+mkNote :: String -> Notify.Note
+mkNote desc = Notify.blankNote
+	{ Notify.appName = "git-annex"
+	, Notify.body = Just $ Notify.Text desc
+	, Notify.hints =
+		[ Notify.Category Notify.Transfer
+		, Notify.Urgency Notify.Low
+		, Notify.SuppressSound True
+		]
+	}
+#endif

Annex/Path.hs

@@ -0,0 +1,34 @@
+{- 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

Annex/Perms.hs

@@ -0,0 +1,125 @@
+{- 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

Annex/Queue.hs

@@ -0,0 +1,62 @@
+{- 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 }

Annex/Quvi.hs

@@ -0,0 +1,33 @@
+{- 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

Annex/ReplaceFile.hs

@@ -0,0 +1,39 @@
+{- 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 a = do
+	tmpdir <- fromRepo gitAnnexTmpMiscDir
+	void $ createAnnexDirectory tmpdir
+	bracketIO (setup tmpdir) nukeFile $ \tmpfile -> do
+		a 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

Annex/Ssh.hs

@@ -0,0 +1,201 @@
+{- git-annex ssh interface, with connection caching
+ -
+ - Copyright 2012,2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE CPP #-}
+
+module Annex.Ssh (
+	sshCachingOptions,
+	sshCacheDir,
+	sshReadPort,
+) where
+
+import qualified Data.Map as M
+import Data.Hash.MD5
+import System.Process (cwd)
+
+import Common.Annex
+import Annex.LockPool
+import qualified Build.SysConfig as SysConfig
+import qualified Annex
+import Config
+import Utility.Env
+import Types.CleanupActions
+#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 = do
+	Annex.addCleanup SshCachingCleanup sshCleanup
+	go =<< sshInfo (host, port)
+  where
+	go (Nothing, params) = ret params
+	go (Just socketfile, params) = do
+		cleanstale
+		liftIO $ createDirectoryIfMissing True $ parentDir socketfile
+		lockFile $ socket2lock socketfile
+		ret params
+	ret ps = return $ ps ++ opts ++ portParams port ++ [Param "-T"]
+	-- 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.
+	cleanstale = whenM (not . any isLock . M.keys <$> getPool)
+		sshCleanup
+
+{- 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
+		createDirectoryIfMissing True tmpdir
+		return tmpdir
+
+portParams :: Maybe Integer -> [CommandParam]
+portParams Nothing = []
+portParams (Just port) = [Param "-p", Param $ show port]
+
+{- Stop any unused ssh processes. -}
+sshCleanup :: Annex ()
+sshCleanup = go =<< sshCacheDir
+  where
+	go Nothing = noop
+	go (Just dir) = do
+		sockets <- liftIO $ filter (not . isLock)
+			<$> catchDefaultIO [] (dirContents dir)
+		forM_ sockets cleanup
+	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.
+		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 _ -> stopssh socketfile
+		liftIO $ closeFd fd
+#else
+		stopssh socketfile
+#endif
+	stopssh 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
+		-- Cannot remove the lock file; other processes may
+		-- be waiting on our exclusive lock to use it.
+
+{- 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

Annex/TaggedPush.hs

@@ -0,0 +1,61 @@
+{- 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)

Annex/Transfer.hs

@@ -0,0 +1,131 @@
+{- 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 _ -> do
+				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

Annex/UUID.hs

@@ -0,0 +1,96 @@
+{- 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,
+	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) $ storeUUID 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 configkey =<< liftIO genUUID
+
+storeUUID :: ConfigKey -> UUID -> Annex ()
+storeUUID 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

Annex/Url.hs

@@ -0,0 +1,42 @@
+{- 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

Annex/VariantFile.hs

@@ -0,0 +1,45 @@
+{- 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

Annex/Version.hs

@@ -0,0 +1,41 @@
+{- 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

Annex/View.hs

@@ -0,0 +1,448 @@
+{- 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 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

Annex/View/ViewedFile.hs

@@ -0,0 +1,75 @@
+{- 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

Annex/Wanted.hs

@@ -0,0 +1,29 @@
+{- 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

Assistant.hs

@@ -0,0 +1,178 @@
+{- 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.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
+#ifndef mingw32_HOST_OS
+import Utility.LogFile
+import Annex.Perms
+#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
+#ifndef mingw32_HOST_OS
+	logfile <- fromRepo gitAnnexLogFile
+	createAnnexDirectory (parentDir logfile)
+	logfd <- liftIO $ openLog logfile
+	if foreground
+		then do
+			origout <- liftIO $ catchMaybeIO $ 
+				fdToHandle =<< dup stdOutput
+			origerr <- liftIO $ catchMaybeIO $ 
+				fdToHandle =<< dup stdError
+			let undaemonize a = do
+				debugM desc $ "logging to " ++ logfile
+				Utility.Daemon.lockPidFile pidfile
+				Utility.LogFile.redirLog logfd
+				a
+			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 is always foreground, and has no log file.
+	when (foreground || not foreground) $ do
+		liftIO $ Utility.Daemon.lockPidFile pidfile
+		start id $ do
+			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 $ 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

Assistant/Alert.hs

@@ -0,0 +1,452 @@
+{- 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 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 :: [Remote] -> TenseChunk
+showRemotes = UnTensed . T.intercalate ", " . map (T.pack . Remote.name)
+
+syncAlert :: [Remote] -> 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 = 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
+	}
+
+xmppNeededAlert :: AlertButton -> Alert
+xmppNeededAlert button = Alert
+	{ alertHeader = Just "Share with friends, and keep your devices in sync across the cloud."
+	, alertIcon = Just TheCloud
+	, alertPriority = High
+	, alertButtons = [button]
+	, alertClosable = True
+	, alertClass = Message
+	, alertMessageRender = renderData
+	, alertCounter = 0
+	, alertBlockDisplay = True
+	, alertName = Just $ XMPPNeededAlert
+	, 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 
+

Assistant/Alert/Utility.hs

@@ -0,0 +1,130 @@
+{- 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

Assistant/BranchChange.hs

@@ -0,0 +1,19 @@
+{- 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)

Assistant/Changes.hs

@@ -0,0 +1,47 @@
+{- 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

Assistant/Commits.hs

@@ -0,0 +1,23 @@
+{- 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

Assistant/Common.hs

@@ -0,0 +1,14 @@
+{- 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

Assistant/DaemonStatus.hs

@@ -0,0 +1,261 @@
+{- git-annex assistant daemon status
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE BangPatterns #-}
+
+module Assistant.DaemonStatus where
+
+import Assistant.Common
+import Assistant.Alert.Utility
+import Utility.Tmp
+import Assistant.Types.NetMessager
+import Utility.NotificationBroadcaster
+import Logs.Transfer
+import Logs.Trust
+import qualified Remote
+import qualified Types.Remote as Remote
+import qualified Git
+
+import Control.Concurrent.STM
+import System.Posix.Types
+import Data.Time.Clock.POSIX
+import Data.Time
+import System.Locale
+import qualified Data.Map as M
+import qualified Data.Text as T
+
+getDaemonStatus :: Assistant DaemonStatus
+getDaemonStatus = (atomically . readTMVar) <<~ daemonStatusHandle
+
+modifyDaemonStatus_ :: (DaemonStatus -> DaemonStatus) -> Assistant ()
+modifyDaemonStatus_ a = modifyDaemonStatus $ \s -> (a s, ())
+
+modifyDaemonStatus :: (DaemonStatus -> (DaemonStatus, b)) -> Assistant b
+modifyDaemonStatus a = do
+	dstatus <- getAssistant daemonStatusHandle
+	liftIO $ do
+		(s, b) <- atomically $ do
+			r@(!s, _) <- a <$> takeTMVar dstatus
+			putTMVar dstatus s
+			return r
+		sendNotification $ changeNotifier s
+		return b
+
+{- Returns a function that updates the lists of syncable remotes
+ - and other associated information. -}
+calcSyncRemotes :: Annex (DaemonStatus -> DaemonStatus)
+calcSyncRemotes = do
+	rs <- filter (remoteAnnexSync . Remote.gitconfig) .
+		concat . Remote.byCost <$> Remote.remoteList
+	alive <- trustExclude DeadTrusted (map Remote.uuid rs)
+	let good r = Remote.uuid r `elem` alive
+	let syncable = filter good rs
+	let syncdata = filter (not . remoteAnnexIgnore . Remote.gitconfig) $
+		filter (not . Remote.isXMPPRemote) syncable
+
+	return $ \dstatus -> dstatus
+		{ syncRemotes = syncable
+		, syncGitRemotes = filter Remote.gitSyncableRemote syncable
+		, syncDataRemotes = syncdata
+		, syncingToCloudRemote = any iscloud syncdata
+		}
+  where
+  	iscloud r = not (Remote.readonly r) && Remote.availability r == Remote.GloballyAvailable
+
+{- Updates the syncRemotes list from the list of all remotes in Annex state. -}
+updateSyncRemotes :: Assistant ()
+updateSyncRemotes = do
+	modifyDaemonStatus_ =<< liftAnnex calcSyncRemotes
+	status <- getDaemonStatus
+	liftIO $ sendNotification $ syncRemotesNotifier status
+
+	when (syncingToCloudRemote status) $
+		updateAlertMap $
+			M.filter $ \alert ->
+				alertName alert /= Just CloudRepoNeededAlert
+
+updateScheduleLog :: Assistant ()
+updateScheduleLog =
+	liftIO . sendNotification =<< scheduleLogNotifier <$> getDaemonStatus
+
+{- Load any previous daemon status file, and store it in a MVar for this
+ - process to use as its DaemonStatus. Also gets current transfer status. -}
+startDaemonStatus :: Annex DaemonStatusHandle
+startDaemonStatus = do
+	file <- fromRepo gitAnnexDaemonStatusFile
+	status <- liftIO $
+		flip catchDefaultIO (readDaemonStatusFile file) =<< newDaemonStatus
+	transfers <- M.fromList <$> getTransfers
+	addsync <- calcSyncRemotes
+	liftIO $ atomically $ newTMVar $ addsync $ status
+		{ scanComplete = False
+		, sanityCheckRunning = False
+		, currentTransfers = transfers
+		}
+
+{- Don't just dump out the structure, because it will change over time,
+ - and parts of it are not relevant. -}
+writeDaemonStatusFile :: FilePath -> DaemonStatus -> IO ()
+writeDaemonStatusFile file status = 
+	viaTmp writeFile file =<< serialized <$> getPOSIXTime
+  where
+	serialized now = unlines
+		[ "lastRunning:" ++ show now
+		, "scanComplete:" ++ show (scanComplete status)
+		, "sanityCheckRunning:" ++ show (sanityCheckRunning status)
+		, "lastSanityCheck:" ++ maybe "" show (lastSanityCheck status)
+		]
+
+readDaemonStatusFile :: FilePath -> IO DaemonStatus
+readDaemonStatusFile file = parse <$> newDaemonStatus <*> readFile file
+  where
+	parse status = foldr parseline status . lines
+	parseline line status
+		| key == "lastRunning" = parseval readtime $ \v ->
+			status { lastRunning = Just v }
+		| key == "scanComplete" = parseval readish $ \v ->
+			status { scanComplete = v }
+		| key == "sanityCheckRunning" = parseval readish $ \v ->
+			status { sanityCheckRunning = v }
+		| key == "lastSanityCheck" = parseval readtime $ \v ->
+			status { lastSanityCheck = Just v }
+		| otherwise = status -- unparsable line
+	  where
+		(key, value) = separate (== ':') line
+		parseval parser a = maybe status a (parser value)
+		readtime s = do
+			d <- parseTime defaultTimeLocale "%s%Qs" s
+			Just $ utcTimeToPOSIXSeconds d
+
+{- Checks if a time stamp was made after the daemon was lastRunning.
+ -
+ - Some slop is built in; this really checks if the time stamp was made
+ - at least ten minutes after the daemon was lastRunning. This is to
+ - ensure the daemon shut down cleanly, and deal with minor clock skew.
+ -
+ - If the daemon has never ran before, this always returns False.
+ -}
+afterLastDaemonRun :: EpochTime -> DaemonStatus -> Bool
+afterLastDaemonRun timestamp status = maybe False (< t) (lastRunning status)
+  where
+	t = realToFrac (timestamp + slop) :: POSIXTime
+	slop = fromIntegral tenMinutes
+
+tenMinutes :: Int
+tenMinutes = 10 * 60
+
+{- Mutates the transfer map. Runs in STM so that the transfer map can
+ - be modified in the same transaction that modifies the transfer queue.
+ - Note that this does not send a notification of the change; that's left
+ - to the caller. -}
+adjustTransfersSTM :: DaemonStatusHandle -> (TransferMap -> TransferMap) -> STM ()
+adjustTransfersSTM dstatus a = do
+	s <- takeTMVar dstatus
+	let !v = a (currentTransfers s)
+	putTMVar dstatus $ s { currentTransfers = v }
+
+{- Checks if a transfer is currently running. -}
+checkRunningTransferSTM :: DaemonStatusHandle -> Transfer -> STM Bool
+checkRunningTransferSTM dstatus t = M.member t . currentTransfers
+	<$> readTMVar dstatus
+
+{- Alters a transfer's info, if the transfer is in the map. -}
+alterTransferInfo :: Transfer -> (TransferInfo -> TransferInfo) -> Assistant ()
+alterTransferInfo t a = updateTransferInfo' $ M.adjust a t
+
+{- Updates a transfer's info. Adds the transfer to the map if necessary,
+ - or if already present, updates it while preserving the old transferTid,
+ - transferPaused, and bytesComplete values, which are not written to disk. -}
+updateTransferInfo :: Transfer -> TransferInfo -> Assistant ()
+updateTransferInfo t info = updateTransferInfo' $ M.insertWith' merge t info
+  where
+	merge new old = new
+		{ transferTid = maybe (transferTid new) Just (transferTid old)
+		, transferPaused = transferPaused new || transferPaused old
+		, bytesComplete = maybe (bytesComplete new) Just (bytesComplete old)
+		}
+
+updateTransferInfo' :: (TransferMap -> TransferMap) -> Assistant ()
+updateTransferInfo' a = notifyTransfer `after` modifyDaemonStatus_ update
+  where
+	update s = s { currentTransfers = a (currentTransfers s) }
+
+{- Removes a transfer from the map, and returns its info. -}
+removeTransfer :: Transfer -> Assistant (Maybe TransferInfo)
+removeTransfer t = notifyTransfer `after` modifyDaemonStatus remove
+  where
+	remove s =
+		let (info, ts) = M.updateLookupWithKey
+			(\_k _v -> Nothing)
+			t (currentTransfers s)
+		in (s { currentTransfers = ts }, info)
+
+{- Send a notification when a transfer is changed. -}
+notifyTransfer :: Assistant ()
+notifyTransfer = do
+	dstatus <- getAssistant daemonStatusHandle
+	liftIO $ sendNotification
+		=<< transferNotifier <$> atomically (readTMVar dstatus)
+
+{- Send a notification when alerts are changed. -}
+notifyAlert :: Assistant ()
+notifyAlert = do
+	dstatus <- getAssistant daemonStatusHandle
+	liftIO $ sendNotification
+		=<< alertNotifier <$> atomically (readTMVar dstatus)
+
+{- Returns the alert's identifier, which can be used to remove it. -}
+addAlert :: Alert -> Assistant AlertId
+addAlert alert = do
+	notice [showAlert alert]
+	notifyAlert `after` modifyDaemonStatus add
+  where
+	add s = (s { lastAlertId = i, alertMap = m }, i)
+	  where
+		!i = nextAlertId $ lastAlertId s
+		!m = mergeAlert i alert (alertMap s)
+
+removeAlert :: AlertId -> Assistant ()
+removeAlert i = updateAlert i (const Nothing)
+
+updateAlert :: AlertId -> (Alert -> Maybe Alert) -> Assistant ()
+updateAlert i a = updateAlertMap $ \m -> M.update a i m
+
+updateAlertMap :: (AlertMap -> AlertMap) -> Assistant ()
+updateAlertMap a = notifyAlert `after` modifyDaemonStatus_ update
+  where
+	update s = 
+		let !m = a (alertMap s)
+		in s { alertMap = m }
+
+{- Displays an alert while performing an activity that returns True on
+ - success.
+ -
+ - The alert is left visible afterwards, as filler.
+ - Old filler is pruned, to prevent the map growing too large. -}
+alertWhile :: Alert -> Assistant Bool -> Assistant Bool
+alertWhile alert a = alertWhile' alert $ do
+	r <- a
+	return (r, r)
+
+{- Like alertWhile, but allows the activity to return a value too. -}
+alertWhile' :: Alert -> Assistant (Bool, a) -> Assistant a
+alertWhile' alert a = do
+	let alert' = alert { alertClass = Activity }
+	i <- addAlert alert'
+	(ok, r) <- a
+	updateAlertMap $ mergeAlert i $ makeAlertFiller ok alert'
+	return r
+
+{- Displays an alert while performing an activity, then removes it. -}
+alertDuring :: Alert -> Assistant a -> Assistant a
+alertDuring alert a = do
+	i <- addAlert $ alert { alertClass = Activity }
+	removeAlert  i `after` a
+
+getXMPPClientID :: Remote -> ClientID
+getXMPPClientID r = T.pack $ drop (length "xmpp::") (Git.repoLocation (Remote.repo r))

Assistant/DeleteRemote.hs

@@ -0,0 +1,89 @@
+{- git-annex assistant remote deletion utilities
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE CPP #-}
+
+module Assistant.DeleteRemote where
+
+import Assistant.Common
+import Assistant.Types.UrlRenderer
+import Assistant.TransferQueue
+import Logs.Transfer
+import Logs.Location
+import Assistant.DaemonStatus
+import qualified Remote
+import Remote.List
+import qualified Git.Remote
+import Logs.Trust
+import qualified Annex
+
+#ifdef WITH_WEBAPP
+import Assistant.WebApp.Types
+import Assistant.Alert
+import qualified Data.Text as T
+#endif
+
+{- Removes a remote (but leave the repository as-is), and returns the old
+ - Remote data. -}
+disableRemote :: UUID -> Assistant Remote
+disableRemote uuid = do
+	remote <- fromMaybe (error "unknown remote")
+		<$> liftAnnex (Remote.remoteFromUUID uuid)
+	liftAnnex $ do
+		inRepo $ Git.Remote.remove (Remote.name remote)
+		void $ remoteListRefresh
+	updateSyncRemotes
+	return remote
+
+{- Removes a remote, marking it dead .-}
+removeRemote :: UUID -> Assistant Remote
+removeRemote uuid = do
+	liftAnnex $ trustSet uuid DeadTrusted
+	disableRemote uuid
+
+{- Called when a Remote is probably empty, to remove it.
+ -
+ - This does one last check for any objects remaining in the Remote,
+ - and if there are any, queues Downloads of them, and defers removing
+ - the remote for later. This is to catch any objects not referred to
+ - in keys in the current branch.
+ -}
+removableRemote :: UrlRenderer -> UUID -> Assistant ()
+removableRemote urlrenderer uuid = do
+	keys <- getkeys
+	if null keys
+		then finishRemovingRemote urlrenderer uuid
+		else do
+			r <- fromMaybe (error "unknown remote")
+				<$> liftAnnex (Remote.remoteFromUUID uuid)
+			mapM_ (queueremaining r) keys
+  where
+  	queueremaining r k = 
+		queueTransferWhenSmall "remaining object in unwanted remote"
+			Nothing (Transfer Download uuid k) r
+	{- Scanning for keys can take a long time; do not tie up
+	 - the Annex monad while doing it, so other threads continue to
+	 - run. -}
+	getkeys = do
+		a <- liftAnnex $ Annex.withCurrentState $ loggedKeysFor uuid
+		liftIO a
+
+{- With the webapp, this asks the user to click on a button to finish
+ - removing the remote.
+ -
+ - Without the webapp, just do the removal now.
+ -}
+finishRemovingRemote :: UrlRenderer -> UUID -> Assistant ()
+#ifdef WITH_WEBAPP
+finishRemovingRemote urlrenderer uuid = do
+	desc <- liftAnnex $ Remote.prettyUUID uuid
+	button <- mkAlertButton True (T.pack "Finish deletion process") urlrenderer $
+		FinishDeleteRepositoryR uuid
+	void $ addAlert $ remoteRemovalAlert desc button
+#else
+finishRemovingRemote _ uuid = void $ removeRemote uuid
+#endif

Assistant/Drop.hs

@@ -0,0 +1,25 @@
+{- git-annex assistant dropping of unwanted content
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Assistant.Drop (
+	handleDrops,
+	handleDropsFrom,
+) where
+
+import Assistant.Common
+import Assistant.DaemonStatus
+import Annex.Drop (handleDropsFrom, Reason)
+import Logs.Location
+import CmdLine.Action
+
+{- Drop from local and/or remote when allowed by the preferred content and
+ - numcopies settings. -}
+handleDrops :: Reason -> Bool -> Key -> AssociatedFile -> Maybe Remote -> Assistant ()
+handleDrops reason fromhere key f knownpresentremote = do
+	syncrs <- syncDataRemotes <$> getDaemonStatus
+	locs <- liftAnnex $ loggedLocations key
+	liftAnnex $ handleDropsFrom locs syncrs reason fromhere key f knownpresentremote callCommandAction

Assistant/Fsck.hs

@@ -0,0 +1,50 @@
+{- git-annex assistant fscking
+ -
+ - Copyright 2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU AGPL version 3 or higher.
+ -}
+
+module Assistant.Fsck where
+
+import Assistant.Common
+import Types.ScheduledActivity
+import qualified Types.Remote as Remote
+import Annex.UUID
+import Assistant.Alert
+import Assistant.Types.UrlRenderer
+import Logs.Schedule
+import qualified Annex
+
+import qualified Data.Set as S
+
+{- Displays a nudge in the webapp if a fsck is not configured for
+ - the specified remote, or for the local repository. -}
+fsckNudge :: UrlRenderer -> Maybe Remote -> Assistant ()
+fsckNudge urlrenderer mr
+	| maybe True fsckableRemote mr =
+		whenM (liftAnnex $ annexFsckNudge <$> Annex.getGitConfig) $
+			unlessM (liftAnnex $ checkFscked mr) $
+				notFsckedNudge urlrenderer mr
+	| otherwise = noop
+
+fsckableRemote :: Remote -> Bool
+fsckableRemote = isJust . Remote.remoteFsck
+
+{- Checks if the remote, or the local repository, has a fsck scheduled.
+ - Only looks at fscks configured to run via the local repository, not
+ - other repositories. -}
+checkFscked :: Maybe Remote -> Annex Bool
+checkFscked mr = any wanted . S.toList <$> (scheduleGet =<< getUUID)
+  where
+	wanted = case mr of
+		Nothing -> isSelfFsck
+		Just r -> flip isFsckOf (Remote.uuid r)
+
+isSelfFsck :: ScheduledActivity -> Bool
+isSelfFsck (ScheduledSelfFsck _ _) = True
+isSelfFsck _ = False
+
+isFsckOf :: ScheduledActivity -> UUID -> Bool
+isFsckOf (ScheduledRemoteFsck u _ _) u' = u == u'
+isFsckOf _ _ = False

Assistant/Gpg.hs

@@ -0,0 +1,36 @@
+{- git-annex assistant gpg stuff
+ -
+ - Copyright 2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU AGPL version 3 or higher.
+ -}
+
+{-# LANGUAGE QuasiQuotes, TemplateHaskell, OverloadedStrings #-}
+
+module Assistant.Gpg where
+
+import Utility.Gpg
+import Utility.UserInfo
+import Types.Remote (RemoteConfigKey)
+
+import qualified Data.Map as M
+
+{- Generates a gpg user id that is not used by any existing secret key -}
+newUserId :: IO UserId
+newUserId = do
+	oldkeys <- secretKeys
+	username <- myUserName
+  	let basekeyname = username ++ "'s git-annex encryption key"
+	return $ Prelude.head $ filter (\n -> M.null $ M.filter (== n) oldkeys)
+		( basekeyname
+		: map (\n -> basekeyname ++ show n) ([2..] :: [Int])
+		)
+
+data EnableEncryption = HybridEncryption | SharedEncryption | NoEncryption
+	deriving (Eq)
+
+{- Generates Remote configuration for encryption. -}
+configureEncryption :: EnableEncryption -> (RemoteConfigKey, String)
+configureEncryption SharedEncryption = ("encryption", "shared")
+configureEncryption NoEncryption = ("encryption", "none")
+configureEncryption HybridEncryption = ("encryption", "hybrid")

Assistant/Install.hs

@@ -0,0 +1,131 @@
+{- Assistant installation
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE CPP #-}
+
+module Assistant.Install where
+
+import Assistant.Common
+import Assistant.Install.AutoStart
+import Config.Files
+import Utility.FileMode
+import Utility.Shell
+import Utility.Tmp
+import Utility.Env
+import Utility.SshConfig
+
+#ifdef darwin_HOST_OS
+import Utility.OSX
+#else
+import Utility.FreeDesktop
+import Assistant.Install.Menu
+#endif
+
+standaloneAppBase :: IO (Maybe FilePath)
+standaloneAppBase = getEnv "GIT_ANNEX_APP_BASE"
+
+{- The standalone app does not have an installation process.
+ - So when it's run, it needs to set up autostarting of the assistant
+ - daemon, as well as writing the programFile, and putting a
+ - git-annex-shell wrapper into ~/.ssh
+ -
+ - Note that this is done every time it's started, so if the user moves
+ - it around, the paths this sets up won't break.
+ -
+ - Nautilus hook script installation is done even for packaged apps,
+ - since it has to go into the user's home directory.
+ -}
+ensureInstalled :: IO ()
+ensureInstalled = go =<< standaloneAppBase
+  where
+	go Nothing = installNautilus "git-annex"
+	go (Just base) = do
+		let program = base </> "git-annex"
+		programfile <- programFile
+		createDirectoryIfMissing True (parentDir programfile)
+		writeFile programfile program
+
+#ifdef darwin_HOST_OS
+		autostartfile <- userAutoStart osxAutoStartLabel
+#else
+		menufile <- desktopMenuFilePath "git-annex" <$> userDataDir
+		icondir <- iconDir <$> userDataDir
+		installMenu program menufile base icondir
+		autostartfile <- autoStartPath "git-annex" <$> userConfigDir
+#endif
+		installAutoStart program autostartfile
+
+		{- This shim is only updated if it doesn't
+		 - already exist with the right content. -}
+		sshdir <- sshDir
+		let shim = sshdir </> "git-annex-shell"
+		let runshell var = "exec " ++ base </> "runshell" ++
+			" git-annex-shell -c \"" ++ var ++ "\""
+		let content = unlines
+			[ shebang_local
+			, "set -e"
+			, "if [ \"x$SSH_ORIGINAL_COMMAND\" != \"x\" ]; then"
+			,   runshell "$SSH_ORIGINAL_COMMAND"
+			, "else"
+			,   runshell "$@"
+			, "fi"
+			]
+
+		curr <- catchDefaultIO "" $ readFileStrict shim
+		when (curr /= content) $ do
+			createDirectoryIfMissing True (parentDir shim)
+			viaTmp writeFile shim content
+			modifyFileMode shim $ addModes [ownerExecuteMode]
+
+		installNautilus program
+
+installNautilus :: FilePath -> IO ()
+#ifdef linux_HOST_OS
+installNautilus program = do
+	scriptdir <- (\d -> d </> "nautilus" </> "scripts") <$> userDataDir
+	genscript scriptdir "get"
+	genscript scriptdir "drop"
+  where
+	genscript scriptdir action =
+		installscript (scriptdir </> scriptname action) $ unlines
+			[ shebang_local
+			, autoaddedcomment
+			, "exec " ++ program ++ " " ++ action ++ " --notify-start --notify-finish -- \"$@\""
+			]
+	scriptname action = "git-annex " ++ action
+	installscript f c = whenM (safetoinstallscript f) $ do
+		writeFile f c
+		modifyFileMode f $ addModes [ownerExecuteMode]
+	safetoinstallscript f = catchDefaultIO True $
+		elem autoaddedcomment . lines <$> readFileStrict f
+	autoaddedcomment = "# Automatically added by git-annex, do not edit. (To disable, chmod 600 this file.)"
+#else
+installNautilus _ = noop
+#endif
+
+{- Returns a cleaned up environment that lacks settings used to make the
+ - standalone builds use their bundled libraries and programs.
+ - Useful when calling programs not included in the standalone builds.
+ -
+ - For a non-standalone build, returns Nothing.
+ -}
+cleanEnvironment :: IO (Maybe [(String, String)])
+cleanEnvironment = clean <$> getEnvironment
+  where
+	clean env
+		| null vars = Nothing
+		| otherwise = Just $ catMaybes $ map (restoreorig env) env
+		| otherwise = Nothing
+	  where
+		vars = words $ fromMaybe "" $
+			lookup "GIT_ANNEX_STANDLONE_ENV" env
+		restoreorig oldenv p@(k, _v)
+			| k `elem` vars = case lookup ("ORIG_" ++ k) oldenv of
+				(Just v')
+					| not (null v') -> Just (k, v')
+				_ -> Nothing
+			| otherwise = Just p

Assistant/Install/AutoStart.hs

@@ -0,0 +1,39 @@
+{- Assistant autostart file installation
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE CPP #-}
+
+module Assistant.Install.AutoStart where
+
+import Utility.FreeDesktop
+#ifdef darwin_HOST_OS
+import Utility.OSX
+import Utility.Path
+import System.Directory
+#endif
+
+installAutoStart :: FilePath -> FilePath -> IO ()
+installAutoStart command file = do
+#ifdef darwin_HOST_OS
+	createDirectoryIfMissing True (parentDir file)
+	writeFile file $ genOSXAutoStartFile osxAutoStartLabel command
+		["assistant", "--autostart"]
+#else
+	writeDesktopMenuFile (fdoAutostart command) file
+#endif
+
+osxAutoStartLabel :: String
+osxAutoStartLabel = "com.branchable.git-annex.assistant"
+
+fdoAutostart :: FilePath -> DesktopEntry
+fdoAutostart command = genDesktopEntry
+	"Git Annex Assistant"
+	"Autostart"
+	False
+	(command ++ " assistant --autostart")
+	Nothing
+	[]

Assistant/Install/Menu.hs

@@ -0,0 +1,47 @@
+{- Assistant menu installation.
+ -
+ - Copyright 2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE CPP #-}
+
+module Assistant.Install.Menu where
+
+import Common
+
+import Utility.FreeDesktop
+
+installMenu :: FilePath -> FilePath -> FilePath -> FilePath -> IO ()
+#ifdef darwin_HOST_OS
+installMenu _command _menufile _iconsrcdir _icondir = return ()
+#else
+installMenu command menufile iconsrcdir icondir = do
+	writeDesktopMenuFile (fdoDesktopMenu command) menufile
+	installIcon (iconsrcdir </> "logo.svg") $
+		iconFilePath (iconBaseName ++ ".svg") "scalable" icondir
+	installIcon (iconsrcdir </> "logo_16x16.png") $
+		iconFilePath (iconBaseName ++ ".png") "16x16" icondir
+#endif
+
+{- The command can be either just "git-annex", or the full path to use
+ - to run it. -}
+fdoDesktopMenu :: FilePath -> DesktopEntry
+fdoDesktopMenu command = genDesktopEntry
+	"Git Annex"
+	"Track and sync the files in your Git Annex"
+	False
+	(command ++ " webapp")
+	(Just iconBaseName)
+	["Network", "FileTransfer"]
+
+installIcon :: FilePath -> FilePath -> IO ()
+installIcon src dest = do
+	createDirectoryIfMissing True (parentDir dest)
+	withBinaryFile src ReadMode $ \hin ->
+		withBinaryFile dest WriteMode $ \hout ->
+			hGetContents hin >>= hPutStr hout
+
+iconBaseName :: String
+iconBaseName = "git-annex"

Assistant/MakeRemote.hs

@@ -0,0 +1,166 @@
+{- git-annex assistant remote creation utilities
+ -
+ - Copyright 2012, 2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Assistant.MakeRemote where
+
+import Assistant.Common
+import Assistant.Ssh
+import qualified Types.Remote as R
+import qualified Remote
+import Remote.List
+import qualified Remote.Rsync as Rsync
+import qualified Remote.GCrypt as GCrypt
+import qualified Git
+import qualified Git.Command
+import qualified Command.InitRemote
+import Logs.UUID
+import Logs.Remote
+import Git.Remote
+import Git.Types (RemoteName)
+import Creds
+import Assistant.Gpg
+import Utility.Gpg (KeyId)
+
+import qualified Data.Map as M
+
+{- Sets up a new git or rsync remote, accessed over ssh. -}
+makeSshRemote :: SshData -> Annex RemoteName
+makeSshRemote sshdata = maker (sshRepoName sshdata) (genSshUrl sshdata)
+  where
+	maker
+		| onlyCapability sshdata RsyncCapable = makeRsyncRemote
+		| otherwise = makeGitRemote
+
+{- Runs an action that returns a name of the remote, and finishes adding it. -}
+addRemote :: Annex RemoteName -> Annex Remote
+addRemote a = do
+	name <- a
+	void remoteListRefresh
+	maybe (error "failed to add remote") return
+		=<< Remote.byName (Just name)
+
+{- Inits a rsync special remote, and returns its name. -}
+makeRsyncRemote :: RemoteName -> String -> Annex String
+makeRsyncRemote name location = makeRemote name location $ const $ void $
+	go =<< Command.InitRemote.findExisting name
+  where
+  	go Nothing = setupSpecialRemote name Rsync.remote config Nothing
+		(Nothing, Command.InitRemote.newConfig name)
+	go (Just (u, c)) = setupSpecialRemote name Rsync.remote config Nothing
+		(Just u, c)
+	config = M.fromList
+		[ ("encryption", "shared")
+		, ("rsyncurl", location)
+		, ("type", "rsync")
+		]
+
+{- Inits a gcrypt special remote, and returns its name. -}
+makeGCryptRemote :: RemoteName -> String -> KeyId -> Annex RemoteName
+makeGCryptRemote remotename location keyid = 
+	initSpecialRemote remotename GCrypt.remote Nothing $ M.fromList
+		[ ("type", "gcrypt")
+		, ("gitrepo", location)
+		, configureEncryption HybridEncryption
+		, ("keyid", keyid)
+		]
+
+type SpecialRemoteMaker = RemoteName -> RemoteType -> Maybe CredPair -> R.RemoteConfig -> Annex RemoteName
+
+{- Inits a new special remote. The name is used as a suggestion, but
+ - will be changed if there is already a special remote with that name. -}
+initSpecialRemote :: SpecialRemoteMaker
+initSpecialRemote name remotetype mcreds config = go 0
+  where
+	go :: Int -> Annex RemoteName
+	go n = do
+		let fullname = if n == 0  then name else name ++ show n
+		r <- Command.InitRemote.findExisting fullname
+		case r of
+			Nothing -> setupSpecialRemote fullname remotetype config mcreds
+				(Nothing, Command.InitRemote.newConfig fullname)
+			Just _ -> go (n + 1)
+
+{- Enables an existing special remote. -}
+enableSpecialRemote :: SpecialRemoteMaker
+enableSpecialRemote name remotetype mcreds config = do
+	r <- Command.InitRemote.findExisting name
+	case r of
+		Nothing -> error $ "Cannot find a special remote named " ++ name
+		Just (u, c) -> setupSpecialRemote name remotetype config mcreds (Just u, c)
+
+setupSpecialRemote :: RemoteName -> RemoteType -> R.RemoteConfig -> Maybe CredPair -> (Maybe UUID, R.RemoteConfig) -> Annex RemoteName
+setupSpecialRemote name remotetype config mcreds (mu, c) = do
+	{- Currently, only 'weak' ciphers can be generated from the
+	 - assistant, because otherwise GnuPG may block once the entropy
+	 - pool is drained, and as of now there's no way to tell the user
+	 - to perform IO actions to refill the pool. -}
+	(c', u) <- R.setup remotetype mu mcreds $
+		M.insert "highRandomQuality" "false" $ M.union config c
+	describeUUID u name
+	configSet u c'
+	return name
+
+{- Returns the name of the git remote it created. If there's already a
+ - remote at the location, returns its name. -}
+makeGitRemote :: String -> String -> Annex RemoteName
+makeGitRemote basename location = makeRemote basename location $ \name ->
+	void $ inRepo $ Git.Command.runBool
+		[Param "remote", Param "add", Param name, Param location]
+
+{- If there's not already a remote at the location, adds it using the
+ - action, which is passed the name of the remote to make.
+ -
+ - Returns the name of the remote. -}
+makeRemote :: String -> String -> (RemoteName -> Annex ()) -> Annex RemoteName
+makeRemote basename location a = do
+	g <- gitRepo
+	if not (any samelocation $ Git.remotes g)
+		then do
+			let name = uniqueRemoteName basename 0 g
+			a name
+			return name
+		else return basename
+  where
+	samelocation x = Git.repoLocation x == location
+
+{- Generate an unused name for a remote, adding a number if
+ - necessary.
+ -
+ - Ensures that the returned name is a legal git remote name. -}
+uniqueRemoteName :: String -> Int -> Git.Repo -> RemoteName
+uniqueRemoteName basename n r
+	| null namecollision = name
+	| otherwise = uniqueRemoteName legalbasename (succ n) r
+  where
+	namecollision = filter samename (Git.remotes r)
+	samename x = Git.remoteName x == Just name
+	name
+		| n == 0 = legalbasename
+		| otherwise = legalbasename ++ show n
+	legalbasename = makeLegalName basename
+
+{- Finds a CredPair belonging to any Remote that is of a given type
+ - and matches some other criteria.
+ -
+ - This can be used as a default when another repository is being set up
+ - using the same service.
+ -
+ - A function must be provided that returns the CredPairStorage
+ - to use for a particular Remote's uuid.
+ -}
+previouslyUsedCredPair
+	:: (UUID -> CredPairStorage)
+	-> RemoteType
+	-> (Remote -> Bool)
+	-> Annex (Maybe CredPair)
+previouslyUsedCredPair getstorage remotetype criteria =
+	getM fromstorage =<< filter criteria . filter sametype <$> remoteList
+  where
+	sametype r = R.typename (R.remotetype r) == R.typename remotetype
+	fromstorage r = do
+		let storage = getstorage (R.uuid r)
+		getRemoteCredPair (R.config r) storage

Assistant/Monad.hs

@@ -0,0 +1,144 @@
+{- git-annex assistant monad
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE GeneralizedNewtypeDeriving, MultiParamTypeClasses #-}
+
+module Assistant.Monad (
+	Assistant,
+	AssistantData(..),
+	newAssistantData,
+	runAssistant,
+	getAssistant,
+	LiftAnnex,
+	liftAnnex,
+	(<~>),
+	(<<~),
+	asIO,
+	asIO1,
+	asIO2,
+	ThreadName,
+	debug,
+	notice
+) where
+
+import "mtl" Control.Monad.Reader
+import System.Log.Logger
+
+import Common.Annex
+import Assistant.Types.ThreadedMonad
+import Assistant.Types.DaemonStatus
+import Assistant.Types.ScanRemotes
+import Assistant.Types.TransferQueue
+import Assistant.Types.TransferSlots
+import Assistant.Types.TransferrerPool
+import Assistant.Types.Pushes
+import Assistant.Types.BranchChange
+import Assistant.Types.Commits
+import Assistant.Types.Changes
+import Assistant.Types.RepoProblem
+import Assistant.Types.Buddies
+import Assistant.Types.NetMessager
+import Assistant.Types.ThreadName
+
+newtype Assistant a = Assistant { mkAssistant :: ReaderT AssistantData IO a }
+	deriving (
+		Monad,
+		MonadIO,
+		MonadReader AssistantData,
+		Functor,
+		Applicative
+	)
+
+data AssistantData = AssistantData
+	{ threadName :: ThreadName
+	, threadState :: ThreadState
+	, daemonStatusHandle :: DaemonStatusHandle
+	, scanRemoteMap :: ScanRemoteMap
+	, transferQueue :: TransferQueue
+	, transferSlots :: TransferSlots
+	, transferrerPool :: TransferrerPool
+	, failedPushMap :: FailedPushMap
+	, commitChan :: CommitChan
+	, changePool :: ChangePool
+	, repoProblemChan :: RepoProblemChan
+	, branchChangeHandle :: BranchChangeHandle
+	, buddyList :: BuddyList
+	, netMessager :: NetMessager
+	}
+
+newAssistantData :: ThreadState -> DaemonStatusHandle -> IO AssistantData
+newAssistantData st dstatus = AssistantData
+	<$> pure (ThreadName "main")
+	<*> pure st
+	<*> pure dstatus
+	<*> newScanRemoteMap
+	<*> newTransferQueue
+	<*> newTransferSlots
+	<*> newTransferrerPool (checkNetworkConnections dstatus)
+	<*> newFailedPushMap
+	<*> newCommitChan
+	<*> newChangePool
+	<*> newRepoProblemChan
+	<*> newBranchChangeHandle
+	<*> newBuddyList
+	<*> newNetMessager
+
+runAssistant :: AssistantData -> Assistant a -> IO a
+runAssistant d a = runReaderT (mkAssistant a) d
+
+getAssistant :: (AssistantData -> a) -> Assistant a
+getAssistant = reader
+
+{- Using a type class for lifting into the annex monad allows
+ - easily lifting to it from multiple different monads. -}
+class LiftAnnex m where
+	liftAnnex :: Annex a -> m a
+
+{- Runs an action in the git-annex monad. Note that the same monad state
+ - is shared among all assistant threads, so only one of these can run at
+ - a time. Therefore, long-duration actions should be avoided. -}
+instance LiftAnnex Assistant where
+	liftAnnex a = do
+		st <- reader threadState
+		liftIO $ runThreadState st a
+
+{- Runs an IO action, passing it an IO action that runs an Assistant action. -}
+(<~>) :: (IO a -> IO b) -> Assistant a -> Assistant b
+io <~> a = do
+	d <- reader id
+	liftIO $ io $ runAssistant d a
+
+{- Creates an IO action that will run an Assistant action when run. -}
+asIO :: Assistant a -> Assistant (IO a)
+asIO a = do
+	d <- reader id
+	return $ runAssistant d a
+
+asIO1 :: (a -> Assistant b) -> Assistant (a -> IO b)
+asIO1 a = do
+	d <- reader id
+	return $ \v -> runAssistant d $ a v
+
+asIO2 :: (a -> b -> Assistant c) -> Assistant (a -> b -> IO c)
+asIO2 a = do
+	d <- reader id
+	return $ \v1 v2 -> runAssistant d (a v1 v2)
+
+{- Runs an IO action on a selected field of the AssistantData. -}
+(<<~) :: (a -> IO b) -> (AssistantData -> a) -> Assistant b
+io <<~ v = reader v >>= liftIO . io
+
+debug :: [String] -> Assistant ()
+debug = logaction debugM
+
+notice :: [String] -> Assistant ()
+notice = logaction noticeM
+
+logaction :: (String -> String -> IO ()) -> [String] -> Assistant ()
+logaction a ws = do
+	ThreadName name <- getAssistant threadName
+	liftIO $ a name $ unwords $ (name ++ ":") : ws

Assistant/NamedThread.hs

@@ -0,0 +1,102 @@
+{- git-annex assistant named threads.
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE CPP #-}
+
+module Assistant.NamedThread where
+
+import Common.Annex
+import Assistant.Types.NamedThread
+import Assistant.Types.ThreadName
+import Assistant.Types.DaemonStatus
+import Assistant.Types.UrlRenderer
+import Assistant.DaemonStatus
+import Assistant.Monad
+import Utility.NotificationBroadcaster
+
+import Control.Concurrent
+import Control.Concurrent.Async
+import qualified Data.Map as M
+import qualified Control.Exception as E
+
+#ifdef WITH_WEBAPP
+import Assistant.WebApp.Types
+import Assistant.Types.Alert
+import Assistant.Alert
+import qualified Data.Text as T
+#endif
+
+{- Starts a named thread, if it's not already running.
+ -
+ - Named threads are run by a management thread, so if they crash
+ - an alert is displayed, allowing the thread to be restarted. -}
+startNamedThread :: UrlRenderer -> NamedThread -> Assistant ()
+startNamedThread urlrenderer (NamedThread afterstartupsanitycheck name a) = do
+	m <- startedThreads <$> getDaemonStatus
+	case M.lookup name m of
+		Nothing -> start
+		Just (aid, _) -> do
+			r <- liftIO (E.try (poll aid) :: IO (Either E.SomeException (Maybe (Either E.SomeException ()))))
+			case r of
+				Right Nothing -> noop
+				_ -> start
+  where
+	start
+		| afterstartupsanitycheck = do
+			status <- getDaemonStatus
+			h <- liftIO $ newNotificationHandle False $
+				startupSanityCheckNotifier status
+			startwith $ runmanaged $
+				liftIO $ waitNotification h
+		| otherwise = startwith $ runmanaged noop
+	startwith runner = do
+		d <- getAssistant id
+		aid <- liftIO $ runner $ d { threadName = name }
+		restart <- asIO $ startNamedThread urlrenderer (NamedThread False name a)
+		modifyDaemonStatus_ $ \s -> s
+			{ startedThreads = M.insertWith' const name (aid, restart) (startedThreads s) }
+	runmanaged first d = do
+		aid <- async $ runAssistant d $ do
+			void first
+			a
+		void $ forkIO $ manager d aid
+		return aid
+	manager d aid = do
+		r <- E.try (wait aid) :: IO (Either E.SomeException ())
+		case r of
+			Right _ -> noop
+			Left e -> do
+				let msg = unwords
+					[ fromThreadName $ threadName d
+					, "crashed:", show e
+					]
+				hPutStrLn stderr msg
+#ifdef WITH_WEBAPP
+				button <- runAssistant d $ mkAlertButton True
+					(T.pack "Restart Thread")
+					urlrenderer 
+					(RestartThreadR name)
+				runAssistant d $ void $ addAlert $
+					(warningAlert (fromThreadName name) msg)
+						{ alertButtons = [button] }
+#endif
+
+namedThreadId :: NamedThread -> Assistant (Maybe ThreadId)
+namedThreadId (NamedThread _ name _) = do
+	m <- startedThreads <$> getDaemonStatus
+	return $ asyncThreadId . fst <$> M.lookup name m
+
+{- Waits for all named threads that have been started to finish.
+ -
+ - Note that if a named thread crashes, it will probably
+ - cause this to crash as well. Also, named threads that are started
+ - after this is called will not be waited on. -}
+waitNamedThreads :: Assistant ()
+waitNamedThreads = do
+	m <- startedThreads <$> getDaemonStatus
+	liftIO $ mapM_ (wait . fst) $ M.elems m
+

Assistant/NetMessager.hs

@@ -0,0 +1,180 @@
+{- git-annex assistant out of band network messager interface
+ -
+ - Copyright 2012-2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE BangPatterns #-}
+
+module Assistant.NetMessager where
+
+import Assistant.Common
+import Assistant.Types.NetMessager
+
+import Control.Concurrent.STM
+import Control.Concurrent.MSampleVar
+import qualified Data.Set as S
+import qualified Data.Map as M
+import qualified Data.DList as D
+
+sendNetMessage :: NetMessage -> Assistant ()
+sendNetMessage m = 
+	(atomically . flip writeTChan m) <<~ (netMessages . netMessager)
+
+waitNetMessage :: Assistant (NetMessage)
+waitNetMessage = (atomically . readTChan) <<~ (netMessages . netMessager)
+
+notifyNetMessagerRestart :: Assistant ()
+notifyNetMessagerRestart =
+	flip writeSV () <<~ (netMessagerRestart . netMessager)
+
+{- This can be used to get an early indication if the network has
+ - changed, to immediately restart a connection. However, that is not
+ - available on all systems, so clients also need to deal with
+ - restarting dropped connections in the usual way. -}
+waitNetMessagerRestart :: Assistant ()
+waitNetMessagerRestart = readSV <<~ (netMessagerRestart . netMessager)
+
+{- Store a new important NetMessage for a client, and if an equivilant
+ - older message is already stored, remove it from both importantNetMessages
+ - and sentImportantNetMessages. -}
+storeImportantNetMessage :: NetMessage -> ClientID -> (ClientID -> Bool) -> Assistant ()
+storeImportantNetMessage m client matchingclient = go <<~ netMessager
+  where
+	go nm = atomically $ do
+		q <- takeTMVar $ importantNetMessages nm
+		sent <- takeTMVar $ sentImportantNetMessages nm
+		putTMVar (importantNetMessages nm) $
+			M.alter (Just . maybe (S.singleton m) (S.insert m)) client $
+				M.mapWithKey removematching q
+		putTMVar (sentImportantNetMessages nm) $
+			M.mapWithKey removematching sent
+	removematching someclient s
+		| matchingclient someclient = S.filter (not . equivilantImportantNetMessages m) s
+		| otherwise = s
+
+{- Indicates that an important NetMessage has been sent to a client. -}
+sentImportantNetMessage :: NetMessage -> ClientID -> Assistant ()
+sentImportantNetMessage m client = go <<~ (sentImportantNetMessages . netMessager)
+  where
+	go v = atomically $ do
+		sent <- takeTMVar v
+		putTMVar v $
+			M.alter (Just . maybe (S.singleton m) (S.insert m)) client sent
+
+{- Checks for important NetMessages that have been stored for a client, and
+ - sent to a client. Typically the same client for both, although 
+ - a modified or more specific client may need to be used. -}
+checkImportantNetMessages :: (ClientID, ClientID) -> Assistant (S.Set NetMessage, S.Set NetMessage)
+checkImportantNetMessages (storedclient, sentclient) = go <<~ netMessager
+  where
+	go nm = atomically $ do
+		stored <- M.lookup storedclient <$> (readTMVar $ importantNetMessages nm)
+		sent <- M.lookup sentclient <$> (readTMVar $ sentImportantNetMessages nm)
+		return (fromMaybe S.empty stored, fromMaybe S.empty sent)
+
+{- Queues a push initiation message in the queue for the appropriate
+ - side of the push but only if there is not already an initiation message
+ - from the same client in the queue. -}
+queuePushInitiation :: NetMessage -> Assistant ()
+queuePushInitiation msg@(Pushing clientid stage) = do
+	tv <- getPushInitiationQueue side
+  	liftIO $ atomically $ do
+		r <- tryTakeTMVar tv
+		case r of
+			Nothing -> putTMVar tv [msg]
+			Just l -> do
+				let !l' = msg : filter differentclient l
+				putTMVar tv l'
+  where
+  	side = pushDestinationSide stage
+	differentclient (Pushing cid _) = cid /= clientid
+	differentclient _ = True
+queuePushInitiation _ = noop
+
+{- Waits for a push inititation message to be received, and runs
+ - function to select a message from the queue. -}
+waitPushInitiation :: PushSide -> ([NetMessage] -> (NetMessage, [NetMessage])) -> Assistant NetMessage
+waitPushInitiation side selector = do
+	tv <- getPushInitiationQueue side
+	liftIO $ atomically $ do
+		q <- takeTMVar tv
+		if null q
+			then retry
+			else do
+				let (msg, !q') = selector q
+				unless (null q') $
+					putTMVar tv q'
+				return msg
+
+{- Stores messages for a push into the appropriate inbox.
+ -
+ - To avoid overflow, only 1000 messages max are stored in any
+ - inbox, which should be far more than necessary.
+ -
+ - TODO: If we have more than 100 inboxes for different clients,
+ - discard old ones that are not currently being used by any push.
+ -}
+storeInbox :: NetMessage -> Assistant ()
+storeInbox msg@(Pushing clientid stage) = do
+	inboxes <- getInboxes side
+	stored <- liftIO $ atomically $ do
+		m <- readTVar inboxes
+		let update = \v -> do
+			writeTVar inboxes $
+				M.insertWith' const clientid v m
+			return True
+		case M.lookup clientid m of
+			Nothing -> update (1, tostore)
+			Just (sz, l)
+				| sz > 1000 -> return False
+				| otherwise ->
+					let !sz' = sz + 1
+					    !l' = D.append l tostore
+					in update (sz', l')
+	if stored
+		then netMessagerDebug clientid ["stored", logNetMessage msg, "in", show side, "inbox"]
+		else netMessagerDebug clientid ["discarded", logNetMessage msg, "; ", show side, "inbox is full"]
+  where
+	side = pushDestinationSide stage
+	tostore = D.singleton msg
+storeInbox _ = noop
+
+{- Gets the new message for a push from its inbox.
+ - Blocks until a message has been received. -}
+waitInbox :: ClientID -> PushSide -> Assistant (NetMessage)
+waitInbox clientid side = do
+	inboxes <- getInboxes side
+	liftIO $ atomically $ do
+		m <- readTVar inboxes
+		case M.lookup clientid m of
+			Nothing -> retry
+			Just (sz, dl)
+				| sz < 1 -> retry
+				| otherwise -> do
+					let msg = D.head dl
+					let dl' = D.tail dl
+					let !sz' = sz - 1
+					writeTVar inboxes $
+						M.insertWith' const clientid (sz', dl') m
+					return msg
+
+emptyInbox :: ClientID -> PushSide -> Assistant ()
+emptyInbox clientid side = do
+	inboxes <- getInboxes side
+	liftIO $ atomically $
+		modifyTVar' inboxes $
+			M.delete clientid
+	
+getInboxes :: PushSide -> Assistant Inboxes
+getInboxes side =
+	getSide side . netMessagerInboxes <$> getAssistant netMessager
+
+getPushInitiationQueue :: PushSide -> Assistant (TMVar [NetMessage])
+getPushInitiationQueue side =
+	getSide side . netMessagerPushInitiations <$> getAssistant netMessager
+
+netMessagerDebug :: ClientID -> [String] -> Assistant ()
+netMessagerDebug clientid l = debug $
+	"NetMessager" : l ++ [show $ logClientID clientid]

Assistant/Pairing.hs

@@ -0,0 +1,92 @@
+{- git-annex assistant repo pairing, core data types
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE CPP #-}
+
+module Assistant.Pairing where
+
+import Common.Annex
+import Utility.Verifiable
+import Assistant.Ssh
+
+import Control.Concurrent
+import Network.Socket
+import Data.Char
+import qualified Data.Text as T
+
+data PairStage
+	{- "I'll pair with anybody who shares the secret that can be used
+	 - to verify this request." -}
+	 = PairReq
+	{- "I've verified your request, and you can verify this to see
+	 - that I know the secret. I set up your ssh key already.
+	 - Here's mine for you to set up." -}
+	| PairAck
+	{- "I saw your PairAck; you can stop sending them." -}
+	| PairDone
+	deriving (Eq, Read, Show, Ord, Enum)
+
+newtype PairMsg = PairMsg (Verifiable (PairStage, PairData, SomeAddr))
+	deriving (Eq, Read, Show)
+
+verifiedPairMsg :: PairMsg -> PairingInProgress -> Bool
+verifiedPairMsg (PairMsg m) pip = verify m $ inProgressSecret pip
+
+fromPairMsg :: PairMsg -> Verifiable (PairStage, PairData, SomeAddr)
+fromPairMsg (PairMsg m) = m
+
+pairMsgStage :: PairMsg -> PairStage
+pairMsgStage (PairMsg (Verifiable (s, _, _) _)) = s
+
+pairMsgData :: PairMsg -> PairData
+pairMsgData (PairMsg (Verifiable (_, d, _) _)) = d
+
+pairMsgAddr :: PairMsg -> SomeAddr
+pairMsgAddr (PairMsg (Verifiable (_, _, a) _)) = a
+
+data PairData = PairData
+	-- uname -n output, not a full domain name
+	{ remoteHostName :: Maybe HostName
+	, remoteUserName :: UserName
+	, remoteDirectory :: FilePath
+	, remoteSshPubKey :: SshPubKey
+	, pairUUID :: UUID
+	}
+	deriving (Eq, Read, Show)
+
+type UserName = String
+
+{- A pairing that is in progress has a secret, a thread that is
+ - broadcasting pairing messages, and a SshKeyPair that has not yet been
+ - set up on disk. -}
+data PairingInProgress = PairingInProgress
+	{ inProgressSecret :: Secret
+	, inProgressThreadId :: Maybe ThreadId
+	, inProgressSshKeyPair :: SshKeyPair
+	, inProgressPairData :: PairData
+	, inProgressPairStage :: PairStage
+	}
+	deriving (Show)
+
+data SomeAddr = IPv4Addr HostAddress
+{- My Android build of the Network library does not currently have IPV6
+ - support. -}
+#ifndef __ANDROID__
+	| IPv6Addr HostAddress6
+#endif
+	deriving (Ord, Eq, Read, Show)
+
+{- This contains the whole secret, just lightly obfuscated to make it not
+ - too obvious. It's only displayed in the user's web browser. -}
+newtype SecretReminder = SecretReminder [Int]
+	deriving (Show, Eq, Ord, Read)
+
+toSecretReminder :: T.Text -> SecretReminder
+toSecretReminder = SecretReminder . map ord . T.unpack
+
+fromSecretReminder :: SecretReminder -> T.Text
+fromSecretReminder (SecretReminder s) = T.pack $ map chr s

Assistant/Pairing/MakeRemote.hs

@@ -0,0 +1,96 @@
+{- git-annex assistant pairing remote creation
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Assistant.Pairing.MakeRemote where
+
+import Assistant.Common
+import Assistant.Ssh
+import Assistant.Pairing
+import Assistant.Pairing.Network
+import Assistant.MakeRemote
+import Assistant.Sync
+import Config.Cost
+import Config
+import qualified Types.Remote as Remote
+
+import Network.Socket
+import qualified Data.Text as T
+
+{- Authorized keys are set up before pairing is complete, so that the other
+ - side can immediately begin syncing. -}
+setupAuthorizedKeys :: PairMsg -> FilePath -> IO ()
+setupAuthorizedKeys msg repodir = do
+	validateSshPubKey pubkey
+	unlessM (liftIO $ addAuthorizedKeys True repodir pubkey) $
+		error "failed setting up ssh authorized keys"
+  where
+	pubkey = remoteSshPubKey $ pairMsgData msg
+
+{- When local pairing is complete, this is used to set up the remote for
+ - the host we paired with. -}
+finishedLocalPairing :: PairMsg -> SshKeyPair -> Assistant ()
+finishedLocalPairing msg keypair = do
+	sshdata <- liftIO $ setupSshKeyPair keypair =<< pairMsgToSshData msg
+	{- Ensure that we know the ssh host key for the host we paired with.
+	 - If we don't, ssh over to get it. -}
+	liftIO $ unlessM (knownHost $ sshHostName sshdata) $
+		void $ sshTranscript
+			[ sshOpt "StrictHostKeyChecking" "no"
+			, sshOpt "NumberOfPasswordPrompts" "0"
+			, "-n"
+			, genSshHost (sshHostName sshdata) (sshUserName sshdata)
+			, "git-annex-shell -c configlist " ++ T.unpack (sshDirectory sshdata)
+			]
+			Nothing
+	r <- liftAnnex $ addRemote $ makeSshRemote sshdata
+	liftAnnex $ setRemoteCost (Remote.repo r) semiExpensiveRemoteCost
+	syncRemote r
+
+{- Mostly a straightforward conversion.  Except:
+ -  * Determine the best hostname to use to contact the host.
+ -  * Strip leading ~/ from the directory name.
+ -}
+pairMsgToSshData :: PairMsg -> IO SshData
+pairMsgToSshData msg = do
+	let d = pairMsgData msg
+	hostname <- liftIO $ bestHostName msg
+	let dir = case remoteDirectory d of
+		('~':'/':v) -> v
+		v -> v
+	return SshData
+		{ sshHostName = T.pack hostname
+		, sshUserName = Just (T.pack $ remoteUserName d)
+		, sshDirectory = T.pack dir
+		, sshRepoName = genSshRepoName hostname dir
+		, sshPort = 22
+		, needsPubKey = True
+		, sshCapabilities = [GitAnnexShellCapable, GitCapable, RsyncCapable]
+		}
+
+{- Finds the best hostname to use for the host that sent the PairMsg.
+ -
+ - If remoteHostName is set, tries to use a .local address based on it.
+ - That's the most robust, if this system supports .local.
+ - Otherwise, looks up the hostname in the DNS for the remoteAddress,
+ - if any. May fall back to remoteAddress if there's no DNS. Ugh. -}
+bestHostName :: PairMsg -> IO HostName
+bestHostName msg = case remoteHostName $ pairMsgData msg of
+	Just h -> do
+		let localname = h ++ ".local"
+		addrs <- catchDefaultIO [] $
+			getAddrInfo Nothing (Just localname) Nothing
+		maybe fallback (const $ return localname) (headMaybe addrs)
+	Nothing -> fallback
+  where
+	fallback = do
+		let a = pairMsgAddr msg
+		let sockaddr = case a of
+			IPv4Addr addr -> SockAddrInet (PortNum 0) addr
+			IPv6Addr addr -> SockAddrInet6 (PortNum 0) 0 addr 0
+		fromMaybe (showAddr a)
+			<$> catchDefaultIO Nothing
+				(fst <$> getNameInfo [] True False sockaddr)

Assistant/Pairing/Network.hs

@@ -0,0 +1,130 @@
+{- git-annex assistant pairing network code
+ -
+ - All network traffic is sent over multicast UDP. For reliability,
+ - each message is repeated until acknowledged. This is done using a
+ - thread, that gets stopped before the next message is sent.
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Assistant.Pairing.Network where
+
+import Assistant.Common
+import Assistant.Pairing
+import Assistant.DaemonStatus
+import Utility.ThreadScheduler
+import Utility.Verifiable
+
+import Network.Multicast
+import Network.Info
+import Network.Socket
+import Control.Exception (bracket)
+import qualified Data.Map as M
+import Control.Concurrent
+
+{- This is an arbitrary port in the dynamic port range, that could
+ - conceivably be used for some other broadcast messages.
+ - If so, hope they ignore the garbage from us; we'll certianly
+ - ignore garbage from them. Wild wild west. -}
+pairingPort :: PortNumber
+pairingPort = 55556
+
+{- Goal: Reach all hosts on the same network segment.
+ - Method: Use same address that avahi uses. Other broadcast addresses seem
+ - to not be let through some routers. -}
+multicastAddress :: SomeAddr -> HostName
+multicastAddress (IPv4Addr _) = "224.0.0.251"
+multicastAddress (IPv6Addr _) = "ff02::fb"
+
+{- Multicasts a message repeatedly on all interfaces, with a 2 second
+ - delay between each transmission. The message is repeated forever
+ - unless a number of repeats is specified.
+ -
+ - The remoteHostAddress is set to the interface's IP address.
+ -
+ - Note that new sockets are opened each time. This is hardly efficient,
+ - but it allows new network interfaces to be used as they come up.
+ - On the other hand, the expensive DNS lookups are cached.
+ -}
+multicastPairMsg :: Maybe Int -> Secret -> PairData -> PairStage -> IO ()
+multicastPairMsg repeats secret pairdata stage = go M.empty repeats
+  where
+	go _ (Just 0) = noop
+	go cache n = do
+		addrs <- activeNetworkAddresses
+		let cache' = updatecache cache addrs
+		mapM_ (sendinterface cache') addrs
+		threadDelaySeconds (Seconds 2)
+		go cache' $ pred <$> n
+	{- The multicast library currently chokes on ipv6 addresses. -}
+	sendinterface _ (IPv6Addr _) = noop
+	sendinterface cache i = void $ tryIO $
+		withSocketsDo $ bracket setup cleanup use
+	  where
+		setup = multicastSender (multicastAddress i) pairingPort
+		cleanup (sock, _) = sClose sock -- FIXME does not work
+		use (sock, addr) = do
+			setInterface sock (showAddr i)
+			maybe noop (\s -> void $ sendTo sock s addr)
+				(M.lookup i cache)
+	updatecache cache [] = cache
+	updatecache cache (i:is)
+		| M.member i cache = updatecache cache is
+		| otherwise = updatecache (M.insert i (show $ mkmsg i) cache) is
+	mkmsg addr = PairMsg $
+		mkVerifiable (stage, pairdata, addr) secret
+
+startSending :: PairingInProgress -> PairStage -> (PairStage -> IO ()) -> Assistant ()
+startSending pip stage sender = do
+	a <- asIO start
+	void $ liftIO $ forkIO a
+  where
+	start = do
+		tid <- liftIO myThreadId
+		let pip' = pip { inProgressPairStage = stage, inProgressThreadId = Just tid }
+		oldpip <- modifyDaemonStatus $
+			\s -> (s { pairingInProgress = Just pip' }, pairingInProgress s)
+		maybe noop stopold oldpip
+		liftIO $ sender stage
+	stopold = maybe noop (liftIO . killThread) . inProgressThreadId
+
+stopSending :: PairingInProgress -> Assistant ()
+stopSending pip = do
+	maybe noop (liftIO . killThread) $ inProgressThreadId pip
+	modifyDaemonStatus_ $ \s -> s { pairingInProgress = Nothing }
+
+class ToSomeAddr a where
+	toSomeAddr :: a -> SomeAddr
+
+instance ToSomeAddr IPv4 where
+	toSomeAddr (IPv4 a) = IPv4Addr a
+
+instance ToSomeAddr IPv6 where
+	toSomeAddr (IPv6 o1 o2 o3 o4) = IPv6Addr (o1, o2, o3, o4)
+
+showAddr :: SomeAddr -> HostName
+showAddr (IPv4Addr a) = show $ IPv4 a
+showAddr (IPv6Addr (o1, o2, o3, o4)) = show $ IPv6 o1 o2 o3 o4
+
+activeNetworkAddresses :: IO [SomeAddr]
+activeNetworkAddresses = filter (not . all (`elem` "0.:") . showAddr)
+	. concatMap (\ni -> [toSomeAddr $ ipv4 ni, toSomeAddr $ ipv6 ni])
+	<$> getNetworkInterfaces
+
+{- A human-visible description of the repository being paired with.
+ - Note that the repository's description is not shown to the user, because
+ - it could be something like "my repo", which is confusing when pairing
+ - with someone else's repo. However, this has the same format as the
+ - default decription of a repo. -}
+pairRepo :: PairMsg -> String
+pairRepo msg = concat
+	[ remoteUserName d
+	, "@"
+	, fromMaybe (showAddr $ pairMsgAddr msg) (remoteHostName d)
+	, ":"
+	, remoteDirectory d
+	]
+  where
+	d = pairMsgData msg

Assistant/Pushes.hs

@@ -0,0 +1,40 @@
+{- git-annex assistant push tracking
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Assistant.Pushes where
+
+import Assistant.Common
+import Assistant.Types.Pushes
+
+import Control.Concurrent.STM
+import Data.Time.Clock
+import qualified Data.Map as M
+
+{- Blocks until there are failed pushes.
+ - Returns Remotes whose pushes failed a given time duration or more ago.
+ - (This may be an empty list.) -}
+getFailedPushesBefore :: NominalDiffTime -> Assistant [Remote]
+getFailedPushesBefore duration = do
+	v <- getAssistant failedPushMap
+	liftIO $ do
+		m <- atomically $ readTMVar v
+		now <- getCurrentTime
+		return $ M.keys $ M.filter (not . toorecent now) m
+  where
+	toorecent now time = now `diffUTCTime` time < duration
+
+{- Modifies the map. -}
+changeFailedPushMap :: (PushMap -> PushMap) -> Assistant ()
+changeFailedPushMap a = do
+	v <- getAssistant failedPushMap
+	liftIO $ atomically $ store v . a . fromMaybe M.empty =<< tryTakeTMVar v
+  where
+	{- tryTakeTMVar empties the TMVar; refill it only if
+	 - the modified map is not itself empty -}
+	store v m
+		| m == M.empty = noop
+		| otherwise = putTMVar v $! m

Assistant/Repair.hs

@@ -0,0 +1,160 @@
+{- git-annex assistant repository repair
+ -
+ - Copyright 2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU AGPL version 3 or higher.
+ -}
+
+{-# LANGUAGE CPP #-}
+
+module Assistant.Repair where
+
+import Assistant.Common
+import Command.Repair (repairAnnexBranch, trackingOrSyncBranch)
+import Git.Fsck (FsckResults, foundBroken)
+import Git.Repair (runRepairOf)
+import qualified Git
+import qualified Remote
+import qualified Types.Remote as Remote
+import Logs.FsckResults
+import Annex.UUID
+import Utility.Batch
+import Config.Files
+import Assistant.Sync
+import Assistant.Alert
+import Assistant.DaemonStatus
+import Assistant.Types.UrlRenderer
+#ifdef WITH_WEBAPP
+import Assistant.WebApp.Types
+import qualified Data.Text as T
+#endif
+import qualified Utility.Lsof as Lsof
+import Utility.ThreadScheduler
+
+import Control.Concurrent.Async
+
+{- When the FsckResults require a repair, tries to do a non-destructive
+ - repair. If that fails, pops up an alert. -}
+repairWhenNecessary :: UrlRenderer -> UUID -> Maybe Remote -> FsckResults -> Assistant Bool
+repairWhenNecessary urlrenderer u mrmt fsckresults
+	| foundBroken fsckresults = do
+		liftAnnex $ writeFsckResults u fsckresults
+		repodesc <- liftAnnex $ Remote.prettyUUID u
+		ok <- alertWhile (repairingAlert repodesc)
+			(runRepair u mrmt False)
+#ifdef WITH_WEBAPP
+		unless ok $ do
+			button <- mkAlertButton True (T.pack "Click Here") urlrenderer $
+				RepairRepositoryR u
+			void $ addAlert $ brokenRepositoryAlert [button]
+#endif
+		return ok
+	| otherwise = return False
+
+runRepair :: UUID -> Maybe Remote -> Bool -> Assistant Bool
+runRepair u mrmt destructiverepair = do
+	fsckresults <- liftAnnex $ readFsckResults u
+	myu <- liftAnnex getUUID
+	ok <- if u == myu
+		then localrepair fsckresults
+		else remoterepair fsckresults
+	liftAnnex $ clearFsckResults u
+	debug [ "Repaired", show u, show ok ]
+
+	return ok
+  where
+  	localrepair fsckresults = do
+		-- Stop the watcher from running while running repairs.
+		changeSyncable Nothing False
+
+		-- This intentionally runs the repair inside the Annex
+		-- monad, which is not strictly necessary, but keeps
+		-- other threads that might be trying to use the Annex
+		-- from running until it completes.
+		ok <- liftAnnex $ repair fsckresults Nothing
+
+		-- Run a background fast fsck if a destructive repair had
+		-- to be done, to ensure that the git-annex branch
+		-- reflects the current state of the repo.
+		when destructiverepair $
+			backgroundfsck [ Param "--fast" ]
+
+		-- Start the watcher running again. This also triggers it to
+		-- do a startup scan, which is especially important if the
+		-- git repo repair removed files from the index file. Those
+		-- files will be seen as new, and re-added to the repository.
+		when (ok || destructiverepair) $
+			changeSyncable Nothing True
+
+		return ok
+
+	remoterepair fsckresults = case Remote.repairRepo =<< mrmt of
+		Nothing -> return False
+		Just mkrepair -> do
+			thisrepopath <- liftIO . absPath
+				=<< liftAnnex (fromRepo Git.repoPath)
+			a <- liftAnnex $ mkrepair $
+				repair fsckresults (Just thisrepopath)
+			liftIO $ catchBoolIO a
+
+	repair fsckresults referencerepo = do
+		(ok, modifiedbranches) <- inRepo $
+			runRepairOf fsckresults trackingOrSyncBranch destructiverepair referencerepo
+		when destructiverepair $
+			repairAnnexBranch modifiedbranches
+		return ok
+	
+	backgroundfsck params = liftIO $ void $ async $ do
+		program <- readProgramFile
+		batchCommand program (Param "fsck" : params)
+
+{- Detect when a git lock file exists and has no git process currently
+ - writing to it. This strongly suggests it is a stale lock file.
+ -
+ - However, this could be on a network filesystem. Which is not very safe
+ - anyway (the assistant relies on being able to check when files have
+ - no writers to know when to commit them). Also, a few lock-file-ish
+ - things used by git are not kept open, particularly MERGE_HEAD.
+ -
+ - So, just in case, when the lock file appears stale, we delay for one
+ - minute, and check its size. If the size changed, delay for another
+ - minute, and so on. This will at work to detect when another machine
+ - is writing out a new index file, since git does so by writing the
+ - new content to index.lock.
+ -
+ - Returns true if locks were cleaned up.
+ -}
+repairStaleGitLocks :: Git.Repo -> Assistant Bool
+repairStaleGitLocks r = do
+	lockfiles <- liftIO $ filter islock <$> findgitfiles r
+	repairStaleLocks lockfiles
+	return $ not $ null lockfiles
+  where
+	findgitfiles = dirContentsRecursiveSkipping (== dropTrailingPathSeparator annexDir) True . Git.localGitDir
+	islock f
+		| "gc.pid" `isInfixOf` f = False
+		| ".lock" `isSuffixOf` f = True
+		| takeFileName f == "MERGE_HEAD" = True
+		| otherwise = False
+
+repairStaleLocks :: [FilePath] -> Assistant ()
+repairStaleLocks lockfiles = go =<< getsizes
+  where
+  	getsize lf = catchMaybeIO $ 
+		(\s -> (lf, fileSize s)) <$> getFileStatus lf
+  	getsizes = liftIO $ catMaybes <$> mapM getsize lockfiles
+	go [] = return ()
+	go l = ifM (liftIO $ null <$> Lsof.query ("--" : map fst l))
+		( do
+			waitforit "to check stale git lock file"
+			l' <- getsizes
+			if l' == l
+				then liftIO $ mapM_ nukeFile (map fst l)
+				else go l'
+		, do
+			waitforit "for git lock file writer"
+			go =<< getsizes
+		)
+	waitforit why = do
+		notice ["Waiting for 60 seconds", why]
+		liftIO $ threadDelaySeconds $ Seconds 60

Assistant/RepoProblem.hs

@@ -0,0 +1,34 @@
+{- git-annex assistant remote problem handling
+ -
+ - Copyright 2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Assistant.RepoProblem where
+
+import Assistant.Common
+import Assistant.Types.RepoProblem
+import Utility.TList
+
+import Control.Concurrent.STM
+
+{- Gets all repositories that have problems. Blocks until there is at
+ - least one. -}
+getRepoProblems :: Assistant [RepoProblem]
+getRepoProblems = nubBy sameRepoProblem
+	<$> (atomically . getTList) <<~ repoProblemChan
+
+{- Indicates that there was a problem with a repository, and the problem
+ - appears to not be a transient (eg network connection) problem.
+ -
+ - If the problem is able to be repaired, the passed action will be run.
+ - (However, if multiple problems are reported with a single repository,
+ - only a single action will be run.)
+ -}
+repoHasProblem :: UUID -> Assistant () -> Assistant ()
+repoHasProblem u afterrepair = do
+	rp <- RepoProblem
+		<$> pure u
+		<*> asIO afterrepair
+	(atomically . flip consTList rp) <<~ repoProblemChan

Assistant/Restart.hs

@@ -0,0 +1,115 @@
+{- git-annex assistant restarting
+ -
+ - Copyright 2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU AGPL version 3 or higher.
+ -}
+
+{-# LANGUAGE CPP #-}
+
+module Assistant.Restart where
+
+import Assistant.Common
+import Assistant.Threads.Watcher
+import Assistant.DaemonStatus
+import Assistant.NamedThread
+import Utility.ThreadScheduler
+import Utility.NotificationBroadcaster
+import Utility.Url
+import Utility.PID
+import qualified Git.Construct
+import qualified Git.Config
+import Config.Files
+import qualified Annex
+import qualified Git
+
+import Control.Concurrent
+import System.Process (cwd)
+#ifndef mingw32_HOST_OS
+import System.Posix (signalProcess, sigTERM)
+#else
+import Utility.WinProcess
+#endif
+import Data.Default
+import Network.URI
+
+{- Before the assistant can be restarted, have to remove our 
+ - gitAnnexUrlFile and our gitAnnexPidFile. Pausing the watcher is also
+ - a good idea, to avoid fighting when two assistants are running in the
+ - same repo.
+ -}
+prepRestart :: Assistant ()
+prepRestart = do
+	liftIO . maybe noop (`throwTo` PauseWatcher) =<< namedThreadId watchThread
+	liftIO . nukeFile =<< liftAnnex (fromRepo gitAnnexUrlFile)
+	liftIO . nukeFile =<< liftAnnex (fromRepo gitAnnexPidFile)
+
+{- To finish a restart, send a global redirect to the new url
+ - to any web browsers that are displaying the webapp.
+ -
+ - Wait for browser to update before terminating this process. -}
+postRestart :: URLString -> Assistant ()
+postRestart url = do
+	modifyDaemonStatus_ $ \status -> status { globalRedirUrl = Just url }
+	liftIO . sendNotification . globalRedirNotifier =<< getDaemonStatus
+	void $ liftIO $ forkIO $ do
+		threadDelaySeconds (Seconds 120)
+#ifndef mingw32_HOST_OS
+		signalProcess sigTERM =<< getPID
+#else
+		terminatePID =<< getPID
+#endif
+
+runRestart :: Assistant URLString
+runRestart = liftIO . newAssistantUrl
+	=<< liftAnnex (Git.repoLocation <$> Annex.gitRepo)
+
+{- Starts up the assistant in the repository, and waits for it to create
+ - a gitAnnexUrlFile. Waits for the assistant to be up and listening for
+ - connections by testing the url. -}
+newAssistantUrl :: FilePath -> IO URLString
+newAssistantUrl repo = do
+	startAssistant repo
+	geturl
+  where
+	geturl = do
+		r <- Git.Config.read =<< Git.Construct.fromPath repo
+		waiturl $ gitAnnexUrlFile r
+	waiturl urlfile = do
+		v <- tryIO $ readFile urlfile
+		case v of
+			Left _ -> delayed $ waiturl urlfile
+			Right url -> ifM (assistantListening url)
+				( return url
+				, delayed $ waiturl urlfile
+				)
+	delayed a = do
+		threadDelay 100000 -- 1/10th of a second
+		a
+
+{- Checks if the assistant is listening on an url.
+ -
+ - Always checks http, because https with self-signed cert is problimatic.
+ - warp-tls listens to http, in order to show an error page, so this works.
+ -}
+assistantListening :: URLString -> IO Bool
+assistantListening url = catchBoolIO $ fst <$> exists url' def
+  where
+	url' = case parseURI url of
+		Nothing -> url
+		Just uri -> show $ uri
+			{ uriScheme = "http:"
+			}
+
+{- Does not wait for assistant to be listening for web connections. 
+ -
+ - On windows, the assistant does not daemonize, which is why the forkIO is
+ - done.
+ -}
+startAssistant :: FilePath -> IO ()
+startAssistant repo = void $ forkIO $ do
+	program <- readProgramFile
+	(_, _, _, pid) <- 
+		createProcess $
+			(proc program ["assistant"]) { cwd = Just repo }
+	void $ checkSuccessProcess pid

Assistant/ScanRemotes.hs

@@ -0,0 +1,41 @@
+{- git-annex assistant remotes needing scanning
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Assistant.ScanRemotes where
+
+import Assistant.Common
+import Assistant.Types.ScanRemotes
+import qualified Types.Remote as Remote
+
+import Data.Function
+import Control.Concurrent.STM
+import qualified Data.Map as M
+
+{- Blocks until there is a remote or remotes that need to be scanned.
+ -
+ - The list has higher priority remotes listed first. -}
+getScanRemote :: Assistant [(Remote, ScanInfo)]
+getScanRemote = do
+	v <- getAssistant scanRemoteMap
+	liftIO $ atomically $
+		reverse . sortBy (compare `on` scanPriority . snd) . M.toList
+			<$> takeTMVar v
+
+{- Adds new remotes that need scanning. -}
+addScanRemotes :: Bool -> [Remote] -> Assistant ()
+addScanRemotes _ [] = noop
+addScanRemotes full rs = do
+	v <- getAssistant scanRemoteMap
+	liftIO $ atomically $ do
+		m <- fromMaybe M.empty <$> tryTakeTMVar v
+		putTMVar v $ M.unionWith merge (M.fromList $ zip rs (map info rs)) m
+  where
+	info r = ScanInfo (-1 * Remote.cost r) full
+	merge x y = ScanInfo
+		{ scanPriority = max (scanPriority x) (scanPriority y)
+		, fullScan = fullScan x || fullScan y 
+		}

Assistant/Ssh.hs

@@ -0,0 +1,352 @@
+{- git-annex assistant ssh utilities
+ -
+ - Copyright 2012-2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Assistant.Ssh where
+
+import Common.Annex
+import Utility.Tmp
+import Utility.Shell
+import Utility.Rsync
+import Utility.FileMode
+import Utility.SshConfig
+import Git.Remote
+
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Char
+import Network.URI
+
+data SshData = SshData
+	{ sshHostName :: Text
+	, sshUserName :: Maybe Text
+	, sshDirectory :: Text
+	, sshRepoName :: String
+	, sshPort :: Int
+	, needsPubKey :: Bool
+	, sshCapabilities :: [SshServerCapability]
+	}
+	deriving (Read, Show, Eq)
+
+data SshServerCapability = GitAnnexShellCapable | GitCapable | RsyncCapable
+	deriving (Read, Show, Eq)
+
+hasCapability :: SshData -> SshServerCapability -> Bool
+hasCapability d c = c `elem` sshCapabilities d
+
+onlyCapability :: SshData -> SshServerCapability -> Bool
+onlyCapability d c = all (== c) (sshCapabilities d)
+
+data SshKeyPair = SshKeyPair
+	{ sshPubKey :: String
+	, sshPrivKey :: String
+	}
+
+instance Show SshKeyPair where
+	show = sshPubKey
+
+type SshPubKey = String
+
+{- ssh -ofoo=bar command-line option -}
+sshOpt :: String -> String -> String
+sshOpt k v = concat ["-o", k, "=", v]
+
+{- user@host or host -}
+genSshHost :: Text -> Maybe Text -> String
+genSshHost host user = maybe "" (\v -> T.unpack v ++ "@") user ++ T.unpack host
+
+{- Generates a ssh or rsync url from a SshData. -}
+genSshUrl :: SshData -> String
+genSshUrl sshdata = addtrailingslash $ T.unpack $ T.concat $
+	if (onlyCapability sshdata RsyncCapable)
+		then [u, h, T.pack ":", sshDirectory sshdata]
+		else [T.pack "ssh://", u, h, d]
+  where
+	u = maybe (T.pack "") (\v -> T.concat [v, T.pack "@"]) $ sshUserName sshdata
+	h = sshHostName sshdata
+	d
+		| T.pack "/" `T.isPrefixOf` sshDirectory sshdata = sshDirectory sshdata
+		| T.pack "~/" `T.isPrefixOf` sshDirectory sshdata = T.concat [T.pack "/", sshDirectory sshdata]
+		| otherwise = T.concat [T.pack "/~/", sshDirectory sshdata]
+	addtrailingslash s
+		| "/" `isSuffixOf` s = s
+		| otherwise = s ++ "/"
+
+{- Reverses genSshUrl -}
+parseSshUrl :: String -> Maybe SshData
+parseSshUrl u
+	| "ssh://" `isPrefixOf` u = fromssh (drop (length "ssh://") u)
+	| otherwise = fromrsync u
+  where
+	mkdata (userhost, dir) = Just $ SshData
+		{ sshHostName = T.pack host
+		, sshUserName = if null user then Nothing else Just $ T.pack user
+		, sshDirectory = T.pack dir
+		, sshRepoName = genSshRepoName host dir
+		-- dummy values, cannot determine from url
+		, sshPort = 22
+		, needsPubKey = True
+		, sshCapabilities = []
+		}
+	  where
+	  	(user, host) = if '@' `elem` userhost
+			then separate (== '@') userhost
+			else ("", userhost)
+	fromrsync s
+		| not (rsyncUrlIsShell u) = Nothing
+		| otherwise = mkdata $ separate (== ':') s
+	fromssh = mkdata . break (== '/')
+
+{- Generates a git remote name, like host_dir or host -}
+genSshRepoName :: String -> FilePath -> String
+genSshRepoName host dir
+	| null dir = makeLegalName host
+	| otherwise = makeLegalName $ host ++ "_" ++ dir
+
+{- The output of ssh, including both stdout and stderr. -}
+sshTranscript :: [String] -> (Maybe String) -> IO (String, Bool)
+sshTranscript opts input = processTranscript "ssh" opts input
+
+{- Ensure that the ssh public key doesn't include any ssh options, like
+ - command=foo, or other weirdness -}
+validateSshPubKey :: SshPubKey -> IO ()
+validateSshPubKey pubkey
+	| length (lines pubkey) == 1 =
+		either error return $ check $ words pubkey
+	| otherwise = error "too many lines in ssh public key"
+  where
+	check [prefix, _key, comment] = do
+		checkprefix prefix
+		checkcomment comment
+	check [prefix, _key] =
+		checkprefix prefix
+	check _ = err "wrong number of words in ssh public key"
+
+	ok = Right ()
+	err msg = Left $ unwords [msg, pubkey]
+
+	checkprefix prefix
+		| ssh == "ssh" && all isAlphaNum keytype = ok
+		| otherwise = err "bad ssh public key prefix"
+	  where
+		(ssh, keytype) = separate (== '-') prefix
+
+	checkcomment comment = case filter (not . safeincomment) comment of
+		[] -> ok
+		badstuff -> err $ "bad comment in ssh public key (contains: \"" ++ badstuff ++ "\")"
+	safeincomment c = isAlphaNum c || c == '@' || c == '-' || c == '_' || c == '.'
+
+addAuthorizedKeys :: Bool -> FilePath -> SshPubKey -> IO Bool
+addAuthorizedKeys gitannexshellonly dir pubkey = boolSystem "sh"
+	[ Param "-c" , Param $ addAuthorizedKeysCommand gitannexshellonly dir pubkey ]
+
+{- Should only be used within the same process that added the line;
+ - the layout of the line is not kepy stable across versions. -}
+removeAuthorizedKeys :: Bool -> FilePath -> SshPubKey -> IO ()
+removeAuthorizedKeys gitannexshellonly dir pubkey = do
+	let keyline = authorizedKeysLine gitannexshellonly dir pubkey
+	sshdir <- sshDir
+	let keyfile = sshdir </> "authorized_keys"
+	ls <- lines <$> readFileStrict keyfile
+	viaTmp writeSshConfig keyfile $ unlines $ filter (/= keyline) ls
+
+{- Implemented as a shell command, so it can be run on remote servers over
+ - ssh.
+ -
+ - The ~/.ssh/git-annex-shell wrapper script is created if not already
+ - present.
+ -}
+addAuthorizedKeysCommand :: Bool -> FilePath -> SshPubKey -> String
+addAuthorizedKeysCommand gitannexshellonly dir pubkey = intercalate "&&"
+	[ "mkdir -p ~/.ssh"
+	, intercalate "; "
+		[ "if [ ! -e " ++ wrapper ++ " ]"
+		, "then (" ++ intercalate ";" (map echoval script) ++ ") > " ++ wrapper
+		, "fi"
+		]
+	, "chmod 700 " ++ wrapper
+	, "touch ~/.ssh/authorized_keys"
+	, "chmod 600 ~/.ssh/authorized_keys"
+	, unwords
+		[ "echo"
+		, shellEscape $ authorizedKeysLine gitannexshellonly dir pubkey
+		, ">>~/.ssh/authorized_keys"
+		]
+	]
+  where
+	echoval v = "echo " ++ shellEscape v
+	wrapper = "~/.ssh/git-annex-shell"
+	script =
+		[ shebang_portable
+		, "set -e"
+		, "if [ \"x$SSH_ORIGINAL_COMMAND\" != \"x\" ]; then"
+		,   runshell "$SSH_ORIGINAL_COMMAND"
+		, "else"
+		,   runshell "$@"
+		, "fi"
+		]
+	runshell var = "exec git-annex-shell -c \"" ++ var ++ "\""
+
+authorizedKeysLine :: Bool -> FilePath -> SshPubKey -> String
+authorizedKeysLine gitannexshellonly dir pubkey
+	| gitannexshellonly = limitcommand ++ pubkey
+	{- TODO: Locking down rsync is difficult, requiring a rather
+	 - long perl script. -}
+	| otherwise = pubkey
+  where
+	limitcommand = "command=\"env GIT_ANNEX_SHELL_DIRECTORY="++shellEscape dir++" ~/.ssh/git-annex-shell\",no-agent-forwarding,no-port-forwarding,no-X11-forwarding,no-pty "
+
+{- Generates a ssh key pair. -}
+genSshKeyPair :: IO SshKeyPair
+genSshKeyPair = withTmpDir "git-annex-keygen" $ \dir -> do
+	ok <- boolSystem "ssh-keygen"
+		[ Param "-P", Param "" -- no password
+		, Param "-f", File $ dir </> "key"
+		]
+	unless ok $
+		error "ssh-keygen failed"
+	SshKeyPair
+		<$> readFile (dir </> "key.pub")
+		<*> readFile (dir </> "key")
+
+{- Installs a ssh key pair, and sets up ssh config with a mangled hostname
+ - that will enable use of the key. This way we avoid changing the user's
+ - regular ssh experience at all. Returns a modified SshData containing the
+ - mangled hostname.
+ -
+ - Note that the key files are put in ~/.ssh/git-annex/, rather than directly
+ - in ssh because of an **INSANE** behavior of gnome-keyring: It loads
+ - ~/.ssh/ANYTHING.pub, and uses them indiscriminately. But using this key
+ - for a normal login to the server will force git-annex-shell to run,
+ - and locks the user out. Luckily, it does not recurse into subdirectories.
+ -
+ - Similarly, IdentitiesOnly is set in the ssh config to prevent the
+ - ssh-agent from forcing use of a different key.
+ -
+ - Force strict host key checking to avoid repeated prompts
+ - when git-annex and git try to access the remote, if its
+ - host key has changed.
+ -}
+setupSshKeyPair :: SshKeyPair -> SshData -> IO SshData
+setupSshKeyPair sshkeypair sshdata = do
+	sshdir <- sshDir
+	createDirectoryIfMissing True $ parentDir $ sshdir </> sshprivkeyfile
+
+	unlessM (doesFileExist $ sshdir </> sshprivkeyfile) $
+		writeFileProtected (sshdir </> sshprivkeyfile) (sshPrivKey sshkeypair)
+	unlessM (doesFileExist $ sshdir </> sshpubkeyfile) $
+		writeFile (sshdir </> sshpubkeyfile) (sshPubKey sshkeypair)
+
+	setSshConfig sshdata
+		[ ("IdentityFile", "~/.ssh/" ++ sshprivkeyfile)
+		, ("IdentitiesOnly", "yes")
+		, ("StrictHostKeyChecking", "yes")
+		]
+  where
+	sshprivkeyfile = "git-annex" </> "key." ++ mangleSshHostName sshdata
+	sshpubkeyfile = sshprivkeyfile ++ ".pub"
+
+{- Fixes git-annex ssh key pairs configured in .ssh/config 
+ - by old versions to set IdentitiesOnly.
+ -
+ - Strategy: Search for IdentityFile lines with key.git-annex
+ - in their names. These are for git-annex ssh key pairs.
+ - Add the IdentitiesOnly line immediately after them, if not already
+ - present.
+ -}
+fixSshKeyPairIdentitiesOnly :: IO ()
+fixSshKeyPairIdentitiesOnly = changeUserSshConfig $ unlines . go [] . lines
+  where
+  	go c [] = reverse c
+	go c (l:[])
+		| all (`isInfixOf` l) indicators = go (fixedline l:l:c) []
+		| otherwise = go (l:c) []
+	go c (l:next:rest)
+		| all (`isInfixOf` l) indicators && not ("IdentitiesOnly" `isInfixOf` next) = 
+			go (fixedline l:l:c) (next:rest)
+		| otherwise = go (l:c) (next:rest)
+  	indicators = ["IdentityFile", "key.git-annex"]
+	fixedline tmpl = takeWhile isSpace tmpl ++ "IdentitiesOnly yes"
+
+{- Add StrictHostKeyChecking to any ssh config stanzas that were written
+ - by git-annex. -}
+fixUpSshRemotes :: IO ()
+fixUpSshRemotes = modifyUserSshConfig (map go)
+  where
+	go c@(HostConfig h _)
+		| "git-annex-" `isPrefixOf` h = fixupconfig c
+		| otherwise = c
+	go other = other
+
+	fixupconfig c = case findHostConfigKey c "StrictHostKeyChecking" of
+		Nothing -> addToHostConfig c "StrictHostKeyChecking" "yes"
+		Just _ -> c
+
+{- Setups up a ssh config with a mangled hostname.
+ - Returns a modified SshData containing the mangled hostname. -}
+setSshConfig :: SshData -> [(String, String)] -> IO SshData
+setSshConfig sshdata config = do
+	sshdir <- sshDir
+	createDirectoryIfMissing True sshdir
+	let configfile = sshdir </> "config"
+	unlessM (catchBoolIO $ isInfixOf mangledhost <$> readFile configfile) $ do
+		appendFile configfile $ unlines $
+			[ ""
+			, "# Added automatically by git-annex"
+			, "Host " ++ mangledhost
+			] ++ map (\(k, v) -> "\t" ++ k ++ " " ++ v)
+				(settings ++ config)
+		setSshConfigMode configfile
+
+	return $ sshdata { sshHostName = T.pack mangledhost }
+  where
+	mangledhost = mangleSshHostName sshdata
+	settings =
+		[ ("Hostname", T.unpack $ sshHostName sshdata)
+		, ("Port", show $ sshPort sshdata)
+		]
+
+{- This hostname is specific to a given repository on the ssh host,
+ - so it is based on the real hostname, the username, and the directory.
+ -
+ - The mangled hostname has the form "git-annex-realhostname-username_dir".
+ - The only use of "-" is to separate the parts shown; this is necessary
+ - to allow unMangleSshHostName to work. Any unusual characters in the
+ - username or directory are url encoded, except using "." rather than "%"
+ - (the latter has special meaning to ssh).
+ -}
+mangleSshHostName :: SshData -> String
+mangleSshHostName sshdata = "git-annex-" ++ T.unpack (sshHostName sshdata)
+	++ "-" ++ escape extra
+  where
+	extra = intercalate "_" $ map T.unpack $ catMaybes
+		[ sshUserName sshdata
+		, Just $ sshDirectory sshdata
+		]
+	safe c
+		| isAlphaNum c = True
+		| c == '_' = True
+		| otherwise = False
+	escape s = replace "%" "." $ escapeURIString safe s
+
+{- Extracts the real hostname from a mangled ssh hostname. -}
+unMangleSshHostName :: String -> String
+unMangleSshHostName h = case split "-" h of
+	("git":"annex":rest) -> intercalate "-" (beginning rest)
+	_ -> h
+
+{- Does ssh have known_hosts data for a hostname? -}
+knownHost :: Text -> IO Bool
+knownHost hostname = do
+	sshdir <- sshDir
+	ifM (doesFileExist $ sshdir </> "known_hosts")
+		( not . null <$> checkhost
+		, return False
+		)
+  where
+	{- ssh-keygen -F can crash on some old known_hosts file -}
+	checkhost = catchDefaultIO "" $
+		readProcess "ssh-keygen" ["-F", T.unpack hostname]

Assistant/Sync.hs

@@ -0,0 +1,277 @@
+{- git-annex assistant repo syncing
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Assistant.Sync where
+
+import Assistant.Common
+import Assistant.Pushes
+import Assistant.NetMessager
+import Assistant.Types.NetMessager
+import Assistant.Alert
+import Assistant.Alert.Utility
+import Assistant.DaemonStatus
+import Assistant.ScanRemotes
+import qualified Command.Sync
+import Utility.Parallel
+import qualified Git
+import qualified Git.Branch
+import qualified Git.Command
+import qualified Git.Ref
+import qualified Remote
+import qualified Types.Remote as Remote
+import qualified Remote.List as Remote
+import qualified Annex.Branch
+import Annex.UUID
+import Annex.TaggedPush
+import qualified Config
+import Git.Config
+import Assistant.NamedThread
+import Assistant.Threads.Watcher (watchThread, WatcherControl(..))
+import Assistant.TransferSlots
+import Assistant.TransferQueue
+import Assistant.RepoProblem
+import Logs.Transfer
+
+import Data.Time.Clock
+import qualified Data.Map as M
+import qualified Data.Set as S
+import Control.Concurrent
+
+{- Syncs with remotes that may have been disconnected for a while.
+ - 
+ - First gets git in sync, and then prepares any necessary file transfers.
+ -
+ - An expensive full scan is queued when the git-annex branches of some of
+ - the remotes have diverged from the local git-annex branch. Otherwise,
+ - it's sufficient to requeue failed transfers.
+ -
+ - XMPP remotes are also signaled that we can push to them, and we request
+ - they push to us. Since XMPP pushes run ansynchronously, any scan of the
+ - XMPP remotes has to be deferred until they're done pushing to us, so
+ - all XMPP remotes are marked as possibly desynced.
+ -
+ - Also handles signaling any connectRemoteNotifiers, after the syncing is
+ - done.
+ -}
+reconnectRemotes :: Bool -> [Remote] -> Assistant ()
+reconnectRemotes _ [] = noop
+reconnectRemotes notifypushes rs = void $ do
+	rs' <- liftIO $ filterM (Remote.checkAvailable True) rs
+	unless (null rs') $ do
+		modifyDaemonStatus_ $ \s -> s
+			{ desynced = S.union (S.fromList $ map Remote.uuid xmppremotes) (desynced s) }
+		failedrs <- syncAction rs' (const go)
+		forM_ failedrs $ \r ->
+			whenM (liftIO $ Remote.checkAvailable False r) $
+				repoHasProblem (Remote.uuid r) (syncRemote r)
+		mapM_ signal $ filter (`notElem` failedrs) rs'
+  where
+	gitremotes = filter (notspecialremote . Remote.repo) rs
+	(xmppremotes, nonxmppremotes) = partition Remote.isXMPPRemote rs
+	notspecialremote r
+		| Git.repoIsUrl r = True
+		| Git.repoIsLocal r = True
+		| Git.repoIsLocalUnknown r = True
+		| otherwise = False
+	sync (Just branch) = do
+		(failedpull, diverged) <- manualPull (Just branch) gitremotes
+		now <- liftIO getCurrentTime
+		failedpush <- pushToRemotes' now notifypushes gitremotes
+		return (nub $ failedpull ++ failedpush, diverged)
+	{- No local branch exists yet, but we can try pulling. -}
+	sync Nothing = manualPull Nothing gitremotes
+	go = do
+		(failed, diverged) <- sync
+			=<< liftAnnex (inRepo Git.Branch.current)
+		addScanRemotes diverged $
+			filter (not . remoteAnnexIgnore . Remote.gitconfig)
+				nonxmppremotes
+		return failed
+	signal r = liftIO . mapM_ (flip tryPutMVar ())
+		=<< fromMaybe [] . M.lookup (Remote.uuid r) . connectRemoteNotifiers
+			<$> getDaemonStatus
+
+{- Updates the local sync branch, then pushes it to all remotes, in
+ - parallel, along with the git-annex branch. This is the same
+ - as "git annex sync", except in parallel, and will co-exist with use of
+ - "git annex sync".
+ -
+ - After the pushes to normal git remotes, also signals XMPP clients that
+ - they can request an XMPP push.
+ -
+ - Avoids running possibly long-duration commands in the Annex monad, so
+ - as not to block other threads.
+ -
+ - This can fail, when the remote's sync branch (or git-annex branch) has
+ - been updated by some other remote pushing into it, or by the remote
+ - itself. To handle failure, a manual pull and merge is done, and the push
+ - is retried.
+ -
+ - When there's a lot of activity, we may fail more than once.
+ - On the other hand, we may fail because the remote is not available.
+ - Rather than retrying indefinitely, after the first retry we enter a
+ - fallback mode, where our push is guarenteed to succeed if the remote is
+ - reachable. If the fallback fails, the push is queued to be retried
+ - later.
+ -
+ - Returns any remotes that it failed to push to.
+ -}
+pushToRemotes :: Bool -> [Remote] -> Assistant [Remote]
+pushToRemotes notifypushes remotes = do
+	now <- liftIO getCurrentTime
+	let remotes' = filter (not . remoteAnnexReadOnly . Remote.gitconfig) remotes
+	syncAction remotes' (pushToRemotes' now notifypushes)
+pushToRemotes' :: UTCTime -> Bool -> [Remote] -> Assistant [Remote]
+pushToRemotes' now notifypushes remotes = do
+	(g, branch, u) <- liftAnnex $ do
+		Annex.Branch.commit "update"
+		(,,)
+			<$> gitRepo
+			<*> inRepo Git.Branch.current
+			<*> getUUID
+	let (xmppremotes, normalremotes) = partition Remote.isXMPPRemote remotes
+	ret <- go True branch g u normalremotes
+	unless (null xmppremotes) $ do
+		shas <- liftAnnex $ map fst <$>
+			inRepo (Git.Ref.matchingWithHEAD
+				[Annex.Branch.fullname, Git.Ref.headRef])
+		forM_ xmppremotes $ \r -> sendNetMessage $
+			Pushing (getXMPPClientID r) (CanPush u shas)
+	return ret
+  where
+	go _ Nothing _ _ _ = return [] -- no branch, so nothing to do
+	go _ _ _ _ [] = return [] -- no remotes, so nothing to do
+	go shouldretry (Just branch) g u rs =  do
+		debug ["pushing to", show rs]
+		liftIO $ Command.Sync.updateBranch (Command.Sync.syncBranch branch) g
+		(succeeded, failed) <- liftIO $ inParallel (push g branch) rs
+		updatemap succeeded []
+		if null failed
+			then do
+				when notifypushes $
+					sendNetMessage $ NotifyPush $
+						map Remote.uuid succeeded
+				return failed
+			else if shouldretry
+				then retry branch g u failed
+				else fallback branch g u failed
+
+	updatemap succeeded failed = changeFailedPushMap $ \m ->
+		M.union (makemap failed) $
+			M.difference m (makemap succeeded)
+	makemap l = M.fromList $ zip l (repeat now)
+
+	retry branch g u rs = do
+		debug ["trying manual pull to resolve failed pushes"]
+		void $ manualPull (Just branch) rs
+		go False (Just branch) g u rs
+
+	fallback branch g u rs = do
+		debug ["fallback pushing to", show rs]
+		(succeeded, failed) <- liftIO $
+			inParallel (\r -> taggedPush u Nothing branch r g) rs
+		updatemap succeeded failed
+		when (notifypushes && (not $ null succeeded)) $
+			sendNetMessage $ NotifyPush $
+				map Remote.uuid succeeded
+		return failed
+		
+	push g branch remote = Command.Sync.pushBranch remote branch g
+
+{- Displays an alert while running an action that syncs with some remotes,
+ - and returns any remotes that it failed to sync with.
+ -
+ - XMPP remotes are handled specially; since the action can only start
+ - an async process for them, they are not included in the alert, but are
+ - still passed to the action.
+ -
+ - Readonly remotes are also hidden (to hide the web special remote).
+ -}
+syncAction :: [Remote] -> ([Remote] -> Assistant [Remote]) -> Assistant [Remote]
+syncAction rs a
+	| null visibleremotes = a rs
+	| otherwise = do
+		i <- addAlert $ syncAlert visibleremotes
+		failed <- a rs
+		let failed' = filter (not . Git.repoIsLocalUnknown . Remote.repo) failed
+		let succeeded = filter (`notElem` failed) visibleremotes
+		if null succeeded && null failed'
+			then removeAlert i
+			else updateAlertMap $ mergeAlert i $
+				syncResultAlert succeeded failed'
+		return failed
+  where
+	visibleremotes = filter (not . Remote.readonly) $
+		filter (not . Remote.isXMPPRemote) rs
+
+{- Manually pull from remotes and merge their branches. Returns any
+ - remotes that it failed to pull from, and a Bool indicating
+ - whether the git-annex branches of the remotes and local had
+ - diverged before the pull.
+ -
+ - After pulling from the normal git remotes, requests pushes from any
+ - XMPP remotes. However, those pushes will run asynchronously, so their
+ - results are not included in the return data.
+ -}
+manualPull :: Maybe Git.Ref -> [Remote] -> Assistant ([Remote], Bool)
+manualPull currentbranch remotes = do
+	g <- liftAnnex gitRepo
+	let (xmppremotes, normalremotes) = partition Remote.isXMPPRemote remotes
+	failed <- liftIO $ forM normalremotes $ \r ->
+		ifM (Git.Command.runBool [Param "fetch", Param $ Remote.name r] g)
+			( return Nothing
+			, return $ Just r
+			)
+	haddiverged <- liftAnnex Annex.Branch.forceUpdate
+	forM_ normalremotes $ \r ->
+		liftAnnex $ Command.Sync.mergeRemote r currentbranch
+	u <- liftAnnex getUUID
+	forM_ xmppremotes $ \r ->
+		sendNetMessage $ Pushing (getXMPPClientID r) (PushRequest u)
+	return (catMaybes failed, haddiverged)
+
+{- Start syncing a remote, using a background thread. -}
+syncRemote :: Remote -> Assistant ()
+syncRemote remote = do
+	updateSyncRemotes
+	thread <- asIO $ do
+		reconnectRemotes False [remote]
+		addScanRemotes True [remote]
+	void $ liftIO $ forkIO $ thread
+
+{- Use Nothing to change autocommit setting; or a remote to change
+ - its sync setting. -}
+changeSyncable :: Maybe Remote -> Bool -> Assistant ()
+changeSyncable Nothing enable = do
+	liftAnnex $ Config.setConfig key (boolConfig enable)
+	liftIO . maybe noop (`throwTo` signal)
+		=<< namedThreadId watchThread
+  where
+	key = Config.annexConfig "autocommit"
+	signal
+		| enable = ResumeWatcher
+		| otherwise = PauseWatcher
+changeSyncable (Just r) True = do
+	liftAnnex $ changeSyncFlag r True
+	syncRemote r
+changeSyncable (Just r) False = do
+	liftAnnex $ changeSyncFlag r False
+	updateSyncRemotes
+	{- Stop all transfers to or from this remote.
+	 - XXX Can't stop any ongoing scan, or git syncs. -}
+	void $ dequeueTransfers tofrom
+	mapM_ (cancelTransfer False) =<<
+		filter tofrom . M.keys . currentTransfers <$> getDaemonStatus
+  where
+	tofrom t = transferUUID t == Remote.uuid r
+
+changeSyncFlag :: Remote -> Bool -> Annex ()
+changeSyncFlag r enabled = do
+	Config.setConfig key (boolConfig enabled)
+	void Remote.remoteListRefresh
+  where
+	key = Config.remoteConfig (Remote.repo r) "sync"

Assistant/Threads/Committer.hs

@@ -0,0 +1,473 @@
+{- git-annex assistant commit thread
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE CPP #-}
+
+module Assistant.Threads.Committer where
+
+import Assistant.Common
+import Assistant.Changes
+import Assistant.Types.Changes
+import Assistant.Commits
+import Assistant.Alert
+import Assistant.DaemonStatus
+import Assistant.TransferQueue
+import Assistant.Drop
+import Logs.Transfer
+import Logs.Location
+import qualified Annex.Queue
+import qualified Git.LsFiles
+import qualified Command.Add
+import Utility.ThreadScheduler
+import qualified Utility.Lsof as Lsof
+import qualified Utility.DirWatcher as DirWatcher
+import Types.KeySource
+import Config
+import Annex.Exception
+import Annex.Content
+import Annex.Link
+import Annex.CatFile
+import qualified Annex
+import Utility.InodeCache
+import Annex.Content.Direct
+import qualified Command.Sync
+
+import Data.Time.Clock
+import Data.Tuple.Utils
+import qualified Data.Set as S
+import qualified Data.Map as M
+import Data.Either
+import Control.Concurrent
+
+{- This thread makes git commits at appropriate times. -}
+commitThread :: NamedThread
+commitThread = namedThread "Committer" $ do
+	havelsof <- liftIO $ inPath "lsof"
+	delayadd <- liftAnnex $
+		maybe delayaddDefault (return . Just . Seconds)
+			=<< annexDelayAdd <$> Annex.getGitConfig
+	waitChangeTime $ \(changes, time) -> do
+		readychanges <- handleAdds havelsof delayadd changes
+		if shouldCommit False time (length readychanges) readychanges
+			then do
+				debug
+					[ "committing"
+					, show (length readychanges)
+					, "changes"
+					]
+				void $ alertWhile commitAlert $
+					liftAnnex commitStaged
+				recordCommit
+				let numchanges = length readychanges
+				mapM_ checkChangeContent readychanges
+				return numchanges
+			else do
+				refill readychanges
+				return 0
+
+refill :: [Change] -> Assistant ()	
+refill [] = noop
+refill cs = do
+	debug ["delaying commit of", show (length cs), "changes"]
+	refillChanges cs
+
+{- Wait for one or more changes to arrive to be committed, and then
+ - runs an action to commit them. If more changes arrive while this is
+ - going on, they're handled intelligently, batching up changes into
+ - large commits where possible, doing rename detection, and
+ - commiting immediately otherwise. -}
+waitChangeTime :: (([Change], UTCTime) -> Assistant Int) -> Assistant ()
+waitChangeTime a = waitchanges 0
+  where
+	waitchanges lastcommitsize = do
+		-- Wait one one second as a simple rate limiter.
+		liftIO $ threadDelaySeconds (Seconds 1)
+		-- Now, wait until at least one change is available for
+		-- processing.
+		cs <- getChanges
+		handlechanges cs lastcommitsize
+	handlechanges changes lastcommitsize = do
+		let len = length changes
+		-- See if now's a good time to commit.
+		now <- liftIO getCurrentTime
+		scanning <- not . scanComplete <$> getDaemonStatus
+		case (lastcommitsize >= maxCommitSize, shouldCommit scanning now len changes, possiblyrename changes) of
+			(True, True, _)
+				| len > maxCommitSize -> 
+					a (changes, now) >>= waitchanges
+				| otherwise -> aftermaxcommit changes
+			(_, True, False) ->
+				a (changes, now) >>= waitchanges
+			(_, True, True) -> do
+				morechanges <- getrelatedchanges changes
+				a (changes ++ morechanges, now) >>= waitchanges
+			_ -> do
+				refill changes
+				waitchanges lastcommitsize
+	
+	{- Did we perhaps only get one of the AddChange and RmChange pair
+	 - that make up a file rename? Or some of the pairs that make up 
+	 - a directory rename?
+	 -}
+	possiblyrename = all renamepart
+
+	renamepart (PendingAddChange _ _) = True
+	renamepart c = isRmChange c
+
+	{- Gets changes related to the passed changes, without blocking
+	 - very long.
+	 -
+	 - If there are multiple RmChanges, this is probably a directory
+	 - rename, in which case it may be necessary to wait longer to get
+	 - all the Changes involved.
+	 -}
+	getrelatedchanges oldchanges
+		| length (filter isRmChange oldchanges) > 1 =
+			concat <$> getbatchchanges []
+		| otherwise = do
+			liftIO humanImperceptibleDelay
+			getAnyChanges
+	getbatchchanges cs = do
+		liftIO $ threadDelay $ fromIntegral $ oneSecond `div` 10
+		cs' <- getAnyChanges
+		if null cs'
+			then return cs
+			else getbatchchanges (cs':cs)
+
+	{- The last commit was maximum size, so it's very likely there
+	 - are more changes and we'd like to ensure we make another commit
+	 - of maximum size if possible.
+	 -
+	 - But, it can take a while for the Watcher to wake back up
+	 - after a commit. It can get blocked by another thread
+	 - that is using the Annex state, such as a git-annex branch
+	 - commit. Especially after such a large commit, this can
+	 - take several seconds. When this happens, it defeats the
+	 - normal commit batching, which sees some old changes the
+	 - Watcher found while the commit was being prepared, and sees
+	 - no recent ones, and wants to commit immediately.
+	 -
+	 - All that we need to do, then, is wait for the Watcher to
+	 - wake up, and queue up one more change.
+	 -
+	 - However, it's also possible that we're at the end of changes for
+	 - now. So to avoid waiting a really long time before committing
+	 - those changes we have, poll for up to 30 seconds, and then
+	 - commit them.
+	 -
+	 - Also, try to run something in Annex, to ensure we block
+	 - longer if the Annex state is indeed blocked.
+	 -}
+	aftermaxcommit oldchanges = loop (30 :: Int)
+	  where
+	  	loop 0 = continue oldchanges
+	  	loop n = do
+			liftAnnex noop -- ensure Annex state is free
+			liftIO $ threadDelaySeconds (Seconds 1)
+			changes <- getAnyChanges
+			if null changes
+				then loop (n - 1)
+				else continue (oldchanges ++ changes)
+		continue cs
+			| null cs = waitchanges 0
+			| otherwise = handlechanges cs 0
+
+isRmChange :: Change -> Bool
+isRmChange (Change { changeInfo = i }) | i == RmChange = True
+isRmChange _ = False
+
+{- An amount of time that is hopefully imperceptably short for humans,
+ - while long enough for a computer to get some work done. 
+ - Note that 0.001 is a little too short for rename change batching to
+ - work. -}
+humanImperceptibleInterval :: NominalDiffTime
+humanImperceptibleInterval = 0.01
+
+humanImperceptibleDelay :: IO ()
+humanImperceptibleDelay = threadDelay $
+	truncate $ humanImperceptibleInterval * fromIntegral oneSecond
+
+maxCommitSize :: Int
+maxCommitSize = 5000
+
+{- Decide if now is a good time to make a commit.
+ - Note that the list of changes has an undefined order.
+ -
+ - Current strategy: If there have been 10 changes within the past second,
+ - a batch activity is taking place, so wait for later.
+ -}
+shouldCommit :: Bool -> UTCTime -> Int -> [Change] -> Bool
+shouldCommit scanning now len changes
+	| scanning = len >= maxCommitSize
+	| len == 0 = False
+	| len >= maxCommitSize = True
+	| length recentchanges < 10 = True
+	| otherwise = False -- batch activity
+  where
+	thissecond c = timeDelta c <= 1
+	recentchanges = filter thissecond changes
+	timeDelta c = now `diffUTCTime` changeTime c
+
+commitStaged :: Annex Bool
+commitStaged = do
+	{- This could fail if there's another commit being made by
+	 - something else. -}
+	v <- tryAnnex Annex.Queue.flush
+	case v of
+		Left _ -> return False
+		Right _ -> Command.Sync.commitStaged ""
+
+{- OSX needs a short delay after a file is added before locking it down,
+ - when using a non-direct mode repository, as pasting a file seems to
+ - try to set file permissions or otherwise access the file after closing
+ - it. -}
+delayaddDefault :: Annex (Maybe Seconds)
+#ifdef darwin_HOST_OS
+delayaddDefault = ifM isDirect
+	( return Nothing
+	, return $ Just $ Seconds 1
+	)
+#else
+delayaddDefault = return Nothing
+#endif
+
+{- If there are PendingAddChanges, or InProcessAddChanges, the files
+ - have not yet actually been added to the annex, and that has to be done
+ - now, before committing.
+ -
+ - Deferring the adds to this point causes batches to be bundled together,
+ - which allows faster checking with lsof that the files are not still open
+ - for write by some other process, and faster checking with git-ls-files
+ - that the files are not already checked into git.
+ -
+ - When a file is added, Inotify will notice the new symlink. So this waits
+ - for additional Changes to arrive, so that the symlink has hopefully been
+ - staged before returning, and will be committed immediately.
+ -
+ - OTOH, for kqueue, eventsCoalesce, so instead the symlink is directly
+ - created and staged.
+ -
+ - Returns a list of all changes that are ready to be committed.
+ - Any pending adds that are not ready yet are put back into the ChangeChan,
+ - where they will be retried later.
+ -}
+handleAdds :: Bool -> Maybe Seconds -> [Change] -> Assistant [Change]
+handleAdds havelsof delayadd cs = returnWhen (null incomplete) $ do
+	let (pending, inprocess) = partition isPendingAddChange incomplete
+	direct <- liftAnnex isDirect
+	(pending', cleanup) <- if direct
+		then return (pending, noop)
+		else findnew pending
+	(postponed, toadd) <- partitionEithers <$> safeToAdd havelsof delayadd pending' inprocess
+	cleanup
+
+	unless (null postponed) $
+		refillChanges postponed
+
+	returnWhen (null toadd) $ do
+		added <- addaction toadd $
+			catMaybes <$> if direct
+				then adddirect toadd
+				else forM toadd add
+		if DirWatcher.eventsCoalesce || null added || direct
+			then return $ added ++ otherchanges
+			else do
+				r <- handleAdds havelsof delayadd =<< getChanges
+				return $ r ++ added ++ otherchanges
+  where
+	(incomplete, otherchanges) = partition (\c -> isPendingAddChange c || isInProcessAddChange c) cs
+		
+	findnew [] = return ([], noop)
+	findnew pending@(exemplar:_) = do
+		(newfiles, cleanup) <- liftAnnex $
+			inRepo (Git.LsFiles.notInRepo False $ map changeFile pending)
+		-- note: timestamp info is lost here
+		let ts = changeTime exemplar
+		return (map (PendingAddChange ts) newfiles, void $ liftIO cleanup)
+
+	returnWhen c a
+		| c = return otherchanges
+		| otherwise = a
+
+	add :: Change -> Assistant (Maybe Change)
+	add change@(InProcessAddChange { keySource = ks }) = 
+		catchDefaultIO Nothing <~> doadd
+	  where
+	  	doadd = sanitycheck ks $ do
+			(mkey, mcache) <- liftAnnex $ do
+				showStart "add" $ keyFilename ks
+				Command.Add.ingest $ Just ks
+			maybe (failedingest change) (done change mcache $ keyFilename ks) mkey
+	add _ = return Nothing
+
+	{- In direct mode, avoid overhead of re-injesting a renamed
+	 - file, by examining the other Changes to see if a removed
+	 - file has the same InodeCache as the new file. If so,
+	 - we can just update bookkeeping, and stage the file in git.
+	 -}
+	adddirect :: [Change] -> Assistant [Maybe Change]
+	adddirect toadd = do
+		ct <- liftAnnex compareInodeCachesWith
+		m <- liftAnnex $ removedKeysMap ct cs
+		if M.null m
+			then forM toadd add
+			else forM toadd $ \c -> do
+				mcache <- liftIO $ genInodeCache $ changeFile c
+				case mcache of
+					Nothing -> add c
+					Just cache ->
+						case M.lookup (inodeCacheToKey ct cache) m of
+							Nothing -> add c
+							Just k -> fastadd c k
+
+	fastadd :: Change -> Key -> Assistant (Maybe Change)
+	fastadd change key = do
+		let source = keySource change
+		liftAnnex $ Command.Add.finishIngestDirect key source
+		done change Nothing (keyFilename source) key
+
+	removedKeysMap :: InodeComparisonType -> [Change] -> Annex (M.Map InodeCacheKey Key)
+	removedKeysMap ct l = do
+		mks <- forM (filter isRmChange l) $ \c ->
+			catKeyFile $ changeFile c
+		M.fromList . concat <$> mapM mkpairs (catMaybes mks)
+	  where
+		mkpairs k = map (\c -> (inodeCacheToKey ct c, k)) <$>
+			recordedInodeCache k
+
+	failedingest change = do
+		refill [retryChange change]
+		liftAnnex showEndFail
+		return Nothing
+
+	done change mcache file key = liftAnnex $ do
+		logStatus key InfoPresent
+		link <- ifM isDirect
+			( inRepo $ gitAnnexLink file key
+			, Command.Add.link file key mcache
+			)
+		whenM (pure DirWatcher.eventsCoalesce <||> isDirect) $
+			stageSymlink file =<< hashSymlink link
+		showEndOk
+		return $ Just $ finishedChange change key
+
+	{- Check that the keysource's keyFilename still exists,
+	 - and is still a hard link to its contentLocation,
+	 - before ingesting it. -}
+	sanitycheck keysource a = do
+		fs <- liftIO $ getSymbolicLinkStatus $ keyFilename keysource
+		ks <- liftIO $ getSymbolicLinkStatus $ contentLocation keysource
+		if deviceID ks == deviceID fs && fileID ks == fileID fs
+			then a
+			else do
+				-- remove the hard link
+				when (contentLocation keysource /= keyFilename keysource) $
+					void $ liftIO $ tryIO $ removeFile $ contentLocation keysource
+				return Nothing
+
+	{- Shown an alert while performing an action to add a file or
+	 - files. When only a few files are added, their names are shown
+	 - in the alert. When it's a batch add, the number of files added
+	 - is shown.
+	 -
+	 - Add errors tend to be transient and will be
+	 - automatically dealt with, so the alert is always told
+	 - the add succeeded.
+	 -}
+	addaction [] a = a
+	addaction toadd a = alertWhile' (addFileAlert $ map changeFile toadd) $
+		(,) 
+			<$> pure True
+			<*> a
+
+{- Files can Either be Right to be added now,
+ - or are unsafe, and must be Left for later.
+ -
+ - Check by running lsof on the repository.
+ -}
+safeToAdd :: Bool -> Maybe Seconds -> [Change] -> [Change] -> Assistant [Either Change Change]
+safeToAdd _ _ [] [] = return []
+safeToAdd havelsof delayadd pending inprocess = do
+	maybe noop (liftIO . threadDelaySeconds) delayadd
+	liftAnnex $ do
+		keysources <- forM pending $ Command.Add.lockDown . changeFile
+		let inprocess' = inprocess ++ mapMaybe mkinprocess (zip pending keysources)
+		openfiles <- if havelsof
+			then S.fromList . map fst3 . filter openwrite <$>
+				findopenfiles (map keySource inprocess')
+			else pure S.empty
+		let checked = map (check openfiles) inprocess'
+
+		{- If new events are received when files are closed,
+		 - there's no need to retry any changes that cannot
+		 - be done now. -}
+		if DirWatcher.closingTracked
+			then do
+				mapM_ canceladd $ lefts checked
+				allRight $ rights checked
+			else return checked
+  where
+	check openfiles change@(InProcessAddChange { keySource = ks })
+		| S.member (contentLocation ks) openfiles = Left change
+	check _ change = Right change
+
+	mkinprocess (c, Just ks) = Just InProcessAddChange
+		{ changeTime = changeTime c
+		, keySource = ks
+		}
+	mkinprocess (_, Nothing) = Nothing
+
+	canceladd (InProcessAddChange { keySource = ks }) = do
+		warning $ keyFilename ks
+			++ " still has writers, not adding"
+		-- remove the hard link
+		when (contentLocation ks /= keyFilename ks) $
+			void $ liftIO $ tryIO $ removeFile $ contentLocation ks
+	canceladd _ = noop
+
+	openwrite (_file, mode, _pid)
+		| mode == Lsof.OpenWriteOnly = True
+		| mode == Lsof.OpenReadWrite = True
+		| mode == Lsof.OpenUnknown = True
+		| otherwise = False
+
+	allRight = return . map Right
+
+	{- Normally the KeySources are locked down inside the temp directory,
+	 - so can just lsof that, which is quite efficient.
+	 -
+	 - In crippled filesystem mode, there is no lock down, so must run lsof
+	 - on each individual file.
+	 -}
+	findopenfiles keysources = ifM crippledFileSystem
+		( liftIO $ do
+			let segments = segmentXargs $ map keyFilename keysources
+			concat <$> forM segments (\fs -> Lsof.query $ "--" : fs)
+		, do
+			tmpdir <- fromRepo gitAnnexTmpMiscDir
+			liftIO $ Lsof.queryDir tmpdir
+		)
+
+{- After a Change is committed, queue any necessary transfers or drops
+ - of the content of the key.
+ -
+ - This is not done during the startup scan, because the expensive
+ - transfer scan does the same thing then.
+ -}
+checkChangeContent :: Change -> Assistant ()
+checkChangeContent change@(Change { changeInfo = i }) =
+	case changeInfoKey i of
+		Nothing -> noop
+		Just k -> whenM (scanComplete <$> getDaemonStatus) $ do
+			present <- liftAnnex $ inAnnex k
+			void $ if present
+				then queueTransfers "new file created" Next k (Just f) Upload
+				else queueTransfers "new or renamed file wanted" Next k (Just f) Download
+			handleDrops "file renamed" present k (Just f) Nothing
+  where
+	f = changeFile change
+checkChangeContent _ = noop

Assistant/Threads/ConfigMonitor.hs

@@ -0,0 +1,91 @@
+{- git-annex assistant config monitor thread
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Assistant.Threads.ConfigMonitor where
+
+import Assistant.Common
+import Assistant.BranchChange
+import Assistant.DaemonStatus
+import Assistant.Commits
+import Utility.ThreadScheduler
+import Logs
+import Logs.UUID
+import Logs.Trust
+import Logs.PreferredContent
+import Logs.Group
+import Logs.NumCopies
+import Remote.List (remoteListRefresh)
+import qualified Git.LsTree as LsTree
+import Git.FilePath
+import qualified Annex.Branch
+
+import qualified Data.Set as S
+
+{- This thread detects when configuration changes have been made to the
+ - git-annex branch and reloads cached configuration.
+ -
+ - If the branch is frequently changing, it's checked for configuration
+ - changes no more often than once every 60 seconds. On the other hand,
+ - if the branch has not changed in a while, configuration changes will
+ - be detected immediately.
+ -}
+configMonitorThread :: NamedThread
+configMonitorThread = namedThread "ConfigMonitor" $ loop =<< getConfigs
+  where
+	loop old = do
+		waitBranchChange
+		new <- getConfigs
+		when (old /= new) $ do
+			let changedconfigs = new `S.difference` old
+			debug $ "reloading config" : 
+				map fst (S.toList changedconfigs)
+			reloadConfigs new
+			{- Record a commit to get this config
+			 - change pushed out to remotes. -}
+			recordCommit
+		liftIO $ threadDelaySeconds (Seconds 60)
+		loop new
+
+{- Config files, and their checksums. -}
+type Configs = S.Set (FilePath, String)
+
+{- All git-annex's config files, and actions to run when they change. -}
+configFilesActions :: [(FilePath, Assistant ())]
+configFilesActions =
+	[ (uuidLog, void $ liftAnnex uuidMapLoad)
+	, (remoteLog, void $ liftAnnex remoteListRefresh)
+	, (trustLog, void $ liftAnnex trustMapLoad)
+	, (groupLog, void $ liftAnnex groupMapLoad)
+	, (numcopiesLog, void $ liftAnnex globalNumCopiesLoad)
+	, (scheduleLog, void updateScheduleLog)
+	-- Preferred and required content settings depend on most of the
+	-- other configs, so will be reloaded whenever any configs change.
+	, (preferredContentLog, noop)
+	, (requiredContentLog, noop)
+	, (groupPreferredContentLog, noop)
+	]
+
+reloadConfigs :: Configs -> Assistant ()
+reloadConfigs changedconfigs = do
+	sequence_ as
+	void $ liftAnnex preferredRequiredMapsLoad
+	{- Changes to the remote log, or the trust log, can affect the
+	 - syncRemotes list. Changes to the uuid log may affect its
+	 - display so are also included. -}
+	when (any (`elem` fs) [remoteLog, trustLog, uuidLog])
+		updateSyncRemotes
+  where
+	(fs, as) = unzip $ filter (flip S.member changedfiles . fst)
+		configFilesActions
+	changedfiles = S.map fst changedconfigs
+
+getConfigs :: Assistant Configs
+getConfigs = S.fromList . map extract
+	<$> liftAnnex (inRepo $ LsTree.lsTreeFiles Annex.Branch.fullname files)
+  where
+	files = map fst configFilesActions
+	extract treeitem = (getTopFilePath $ LsTree.file treeitem, LsTree.sha treeitem)

Assistant/Threads/Cronner.hs

@@ -0,0 +1,225 @@
+{- git-annex assistant sceduled jobs runner
+ -
+ - Copyright 2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE DeriveDataTypeable #-}
+
+module Assistant.Threads.Cronner (
+	cronnerThread
+) where
+
+import Assistant.Common
+import Assistant.DaemonStatus
+import Utility.NotificationBroadcaster
+import Annex.UUID
+import Config.Files
+import Logs.Schedule
+import Utility.Scheduled
+import Types.ScheduledActivity
+import Utility.ThreadScheduler
+import Utility.HumanTime
+import Utility.Batch
+import Assistant.TransferQueue
+import Annex.Content
+import Logs.Transfer
+import Assistant.Types.UrlRenderer
+import Assistant.Alert
+import Remote
+import qualified Types.Remote as Remote
+import qualified Git
+import qualified Git.Fsck
+import Assistant.Fsck
+import Assistant.Repair
+
+import Control.Concurrent.Async
+import Control.Concurrent.MVar
+import Data.Time.LocalTime
+import Data.Time.Clock
+import qualified Data.Map as M
+import qualified Data.Set as S
+
+{- Loads schedules for this repository, and fires off one thread for each 
+ - scheduled event that runs on this repository. Each thread sleeps until
+ - its event is scheduled to run.
+ -
+ - To handle events that run on remotes, which need to only run when
+ - their remote gets connected, threads are also started, and are passed
+ - a MVar to wait on, which is stored in the DaemonStatus's
+ - connectRemoteNotifiers.
+ -
+ - In the meantime the main thread waits for any changes to the
+ - schedules. When there's a change, compare the old and new list of
+ - schedules to find deleted and added ones. Start new threads for added
+ - ones, and kill the threads for deleted ones. -}
+cronnerThread :: UrlRenderer -> NamedThread
+cronnerThread urlrenderer = namedThreadUnchecked "Cronner" $ do
+	fsckNudge urlrenderer Nothing
+	dstatus <- getDaemonStatus
+	h <- liftIO $ newNotificationHandle False (scheduleLogNotifier dstatus)
+	go h M.empty M.empty
+  where
+	go h amap nmap = do
+		activities <- liftAnnex $ scheduleGet =<< getUUID
+
+		let addedactivities = activities `S.difference` M.keysSet amap
+		let removedactivities = M.keysSet amap `S.difference` activities
+
+		forM_ (S.toList removedactivities) $ \activity ->
+			case M.lookup activity amap of
+				Just a -> do
+					debug ["stopping removed job for", fromScheduledActivity activity, show (asyncThreadId a)]
+					liftIO $ cancel a
+				Nothing -> noop
+
+		lastruntimes <- liftAnnex getLastRunTimes
+		started <- startactivities (S.toList addedactivities) lastruntimes
+		let addedamap = M.fromList $ map fst started
+		let addednmap = M.fromList $ catMaybes $ map snd started
+
+		let removefiltered = M.filterWithKey (\k _ -> S.member k removedactivities)
+		let amap' = M.difference (M.union addedamap amap) (removefiltered amap)
+		let nmap' = M.difference (M.union addednmap nmap) (removefiltered nmap)
+		modifyDaemonStatus_ $ \s -> s { connectRemoteNotifiers = M.fromListWith (++) (M.elems nmap') }
+
+		liftIO $ waitNotification h
+		debug ["reloading changed activities"]
+		go h amap' nmap'
+  	startactivities as lastruntimes = forM as $ \activity ->
+		case connectActivityUUID activity of
+			Nothing -> do
+				runner <- asIO2 (sleepingActivityThread urlrenderer)
+				a <- liftIO $ async $
+					runner activity (M.lookup activity lastruntimes)
+				return ((activity, a), Nothing)
+			Just u -> do
+				mvar <- liftIO newEmptyMVar
+				runner <- asIO2 (remoteActivityThread urlrenderer mvar)
+				a <- liftIO $ async $
+					runner activity (M.lookup activity lastruntimes)
+				return ((activity, a), Just (activity, (u, [mvar])))
+
+{- Calculate the next time the activity is scheduled to run, then
+ - sleep until that time, and run it. Then call setLastRunTime, and
+ - loop.
+ -}
+sleepingActivityThread :: UrlRenderer -> ScheduledActivity -> Maybe LocalTime -> Assistant ()
+sleepingActivityThread urlrenderer activity lasttime = go lasttime =<< getnexttime lasttime
+  where
+  	getnexttime = liftIO . nextTime schedule
+  	go _ Nothing = debug ["no scheduled events left for", desc]
+	go l (Just (NextTimeExactly t)) = waitrun l t Nothing
+	go l (Just (NextTimeWindow windowstart windowend)) =
+		waitrun l windowstart (Just windowend)
+	desc = fromScheduledActivity activity
+	schedule = getSchedule activity
+	waitrun l t mmaxt = do
+		seconds <- liftIO $ secondsUntilLocalTime t
+		when (seconds > Seconds 0) $ do
+			debug ["waiting", show seconds, "for next scheduled", desc]
+			liftIO $ threadDelaySeconds seconds
+		now <- liftIO getCurrentTime
+		tz <- liftIO $ getTimeZone now
+		let nowt = utcToLocalTime tz now
+		if tolate nowt tz
+			then do
+				debug ["too late to run scheduled", desc]
+				go l =<< getnexttime l
+			else run nowt
+	  where
+	  	tolate nowt tz = case mmaxt of
+			Just maxt -> nowt > maxt
+			-- allow the job to start 10 minutes late
+			Nothing ->diffUTCTime 
+				(localTimeToUTC tz nowt)
+				(localTimeToUTC tz t) > 600
+	run nowt = do
+		runActivity urlrenderer activity nowt
+		go (Just nowt) =<< getnexttime (Just nowt)
+
+{- Wait for the remote to become available by waiting on the MVar.
+ - Then check if the time is within a time window when activity
+ - is scheduled to run, and if so run it.
+ - Otherwise, just wait again on the MVar.
+ -}
+remoteActivityThread :: UrlRenderer -> MVar () -> ScheduledActivity -> Maybe LocalTime -> Assistant ()
+remoteActivityThread urlrenderer mvar activity lasttime = do
+	liftIO $ takeMVar mvar
+	go =<< liftIO (nextTime (getSchedule activity) lasttime)
+  where
+	go (Just (NextTimeWindow windowstart windowend)) = do
+		now <- liftIO getCurrentTime
+		tz <- liftIO $ getTimeZone now
+		if now >= localTimeToUTC tz windowstart && now <= localTimeToUTC tz windowend
+			then do
+				let nowt = utcToLocalTime tz now
+				runActivity urlrenderer activity nowt
+				loop (Just nowt)
+			else loop lasttime
+	go _ = noop -- running at exact time not handled here
+	loop = remoteActivityThread urlrenderer mvar activity
+
+secondsUntilLocalTime :: LocalTime -> IO Seconds
+secondsUntilLocalTime t = do
+	now <- getCurrentTime
+	tz <- getTimeZone now
+	let secs = truncate $ diffUTCTime (localTimeToUTC tz t) now
+	return $ if secs > 0
+		then Seconds secs
+		else Seconds 0
+
+runActivity :: UrlRenderer -> ScheduledActivity -> LocalTime -> Assistant ()
+runActivity urlrenderer activity nowt = do
+	debug ["starting", desc]
+	runActivity' urlrenderer activity
+	debug ["finished", desc]
+	liftAnnex $ setLastRunTime activity nowt
+  where
+	desc = fromScheduledActivity activity
+
+runActivity' :: UrlRenderer -> ScheduledActivity -> Assistant ()
+runActivity' urlrenderer (ScheduledSelfFsck _ d) = do
+	program <- liftIO $ readProgramFile
+	g <- liftAnnex gitRepo
+	fsckresults <- showFscking urlrenderer Nothing $ tryNonAsync $ do
+		void $ batchCommand program (Param "fsck" : annexFsckParams d)
+		Git.Fsck.findBroken True g
+	u <- liftAnnex getUUID
+	void $ repairWhenNecessary urlrenderer u Nothing fsckresults
+	mapM_ reget =<< liftAnnex (dirKeys gitAnnexBadDir)
+  where
+	reget k = queueTransfers "fsck found bad file; redownloading" Next k Nothing Download
+runActivity' urlrenderer (ScheduledRemoteFsck u s d) = handle =<< liftAnnex (remoteFromUUID u)
+  where
+	handle Nothing = debug ["skipping remote fsck of uuid without a configured remote", fromUUID u, fromSchedule s]
+	handle (Just rmt) = void $ case Remote.remoteFsck rmt of
+		Nothing -> go rmt $ do
+			program <- readProgramFile
+			void $ batchCommand program $ 
+				[ Param "fsck"
+				-- avoid downloading files
+				, Param "--fast"
+				, Param "--from"
+				, Param $ Remote.name rmt
+				] ++ annexFsckParams d
+		Just mkfscker -> do
+			{- Note that having mkfsker return an IO action
+			 - avoids running a long duration fsck in the
+			 - Annex monad. -}
+			go rmt =<< liftAnnex (mkfscker (annexFsckParams d))
+	go rmt annexfscker = do
+		fsckresults <- showFscking urlrenderer (Just rmt) $ tryNonAsync $ do
+			void annexfscker
+			let r = Remote.repo rmt
+			if Git.repoIsLocal r && not (Git.repoIsLocalUnknown r)
+				then Just <$> Git.Fsck.findBroken True r
+				else pure Nothing
+		maybe noop (void . repairWhenNecessary urlrenderer u (Just rmt)) fsckresults
+
+annexFsckParams :: Duration -> [CommandParam]
+annexFsckParams d =
+	[ Param "--incremental-schedule=1d"
+	, Param $ "--time-limit=" ++ fromDuration d
+	]

Assistant/Threads/DaemonStatus.hs

@@ -0,0 +1,29 @@
+{- git-annex assistant daemon status thread
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Assistant.Threads.DaemonStatus where
+
+import Assistant.Common
+import Assistant.DaemonStatus
+import Utility.ThreadScheduler
+import Utility.NotificationBroadcaster
+
+{- This writes the daemon status to disk, when it changes, but no more
+ - frequently than once every ten minutes.
+ -}
+daemonStatusThread :: NamedThread
+daemonStatusThread = namedThread "DaemonStatus" $ do
+	notifier <- liftIO . newNotificationHandle False
+		=<< changeNotifier <$> getDaemonStatus
+	checkpoint
+	runEvery (Seconds tenMinutes) <~> do
+		liftIO $ waitNotification notifier
+		checkpoint
+  where
+	checkpoint = do
+		file <- liftAnnex $ fromRepo gitAnnexDaemonStatusFile
+		liftIO . writeDaemonStatusFile file =<< getDaemonStatus

Assistant/Threads/Glacier.hs

@@ -0,0 +1,43 @@
+{- git-annex assistant Amazon Glacier retrieval
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Assistant.Threads.Glacier where
+
+import Assistant.Common
+import Utility.ThreadScheduler
+import qualified Types.Remote as Remote
+import qualified Remote.Glacier as Glacier
+import Logs.Transfer
+import Assistant.DaemonStatus
+import Assistant.TransferQueue
+
+import qualified Data.Set as S
+
+{- Wakes up every half hour and checks if any glacier remotes have failed
+ - downloads. If so, runs glacier-cli to check if the files are now
+ - available, and queues the downloads. -}
+glacierThread :: NamedThread
+glacierThread = namedThread "Glacier" $ runEvery (Seconds 3600) <~> go
+  where
+	isglacier r = Remote.remotetype r == Glacier.remote
+	go = do
+		rs <- filter isglacier . syncDataRemotes <$> getDaemonStatus
+		forM_ rs $ \r -> 
+			check r =<< liftAnnex (getFailedTransfers $ Remote.uuid r)
+	check _ [] = noop
+	check r l = do
+		let keys = map getkey l
+		(availkeys, failedkeys) <- liftAnnex $ Glacier.jobList r keys
+		let s = S.fromList (failedkeys ++ availkeys)
+		let l' = filter (\p -> S.member (getkey p) s) l
+		forM_ l' $ \(t, info) -> do
+			liftAnnex $ removeFailedTransfer t
+			queueTransferWhenSmall "object available from glacier" (associatedFile info) t r
+	getkey = transferKey . fst

Assistant/Threads/Merger.hs

@@ -0,0 +1,118 @@
+{- git-annex assistant git merge thread
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Assistant.Threads.Merger where
+
+import Assistant.Common
+import Assistant.TransferQueue
+import Assistant.BranchChange
+import Assistant.DaemonStatus
+import Assistant.ScanRemotes
+import Utility.DirWatcher
+import Utility.DirWatcher.Types
+import qualified Annex.Branch
+import qualified Git
+import qualified Git.Branch
+import Annex.AutoMerge
+import Annex.TaggedPush
+import Remote (remoteFromUUID)
+
+import qualified Data.Set as S
+import qualified Data.Text as T
+
+{- This thread watches for changes to .git/refs/, and handles incoming
+ - pushes. -}
+mergeThread :: NamedThread
+mergeThread = namedThread "Merger" $ do
+	g <- liftAnnex gitRepo
+	let dir = Git.localGitDir g </> "refs"
+	liftIO $ createDirectoryIfMissing True dir
+	let hook a = Just <$> asIO2 (runHandler a)
+	changehook <- hook onChange
+	errhook <- hook onErr
+	let hooks = mkWatchHooks
+		{ addHook = changehook
+		, modifyHook = changehook
+		, errHook = errhook
+		}
+	void $ liftIO $ watchDir dir (const False) True hooks id
+	debug ["watching", dir]
+
+type Handler = FilePath -> Assistant ()
+
+{- Runs an action handler.
+ -
+ - Exceptions are ignored, otherwise a whole thread could be crashed.
+ -}
+runHandler :: Handler -> FilePath -> Maybe FileStatus -> Assistant ()
+runHandler handler file _filestatus =
+	either (liftIO . print) (const noop) =<< tryIO <~> handler file
+
+{- Called when there's an error with inotify. -}
+onErr :: Handler
+onErr = error
+
+{- Called when a new branch ref is written, or a branch ref is modified.
+ -
+ - At startup, synthetic add events fire, causing this to run, but that's
+ - ok; it ensures that any changes pushed since the last time the assistant
+ - ran are merged in.
+ -}
+onChange :: Handler
+onChange file
+	| ".lock" `isSuffixOf` file = noop
+	| isAnnexBranch file = do
+		branchChanged
+		diverged <- liftAnnex Annex.Branch.forceUpdate
+		when diverged $
+			unlessM handleDesynced $
+				queueDeferredDownloads "retrying deferred download" Later
+	| "/synced/" `isInfixOf` file =
+		mergecurrent =<< liftAnnex (inRepo Git.Branch.current)
+	| otherwise = noop
+  where
+	changedbranch = fileToBranch file
+
+	mergecurrent (Just current)
+		| equivBranches changedbranch current = do
+			debug
+				[ "merging", Git.fromRef changedbranch
+				, "into", Git.fromRef current
+				]
+			void $ liftAnnex  $ autoMergeFrom changedbranch (Just current)
+	mergecurrent _ = noop
+
+	handleDesynced = case fromTaggedBranch changedbranch of
+		Nothing -> return False
+		Just (u, info) -> do
+			mr <- liftAnnex $ remoteFromUUID u
+			case mr of
+				Nothing -> return False
+				Just r -> do
+					s <- desynced <$> getDaemonStatus
+					if S.member u s || Just (T.unpack $ getXMPPClientID r) == info
+						then do
+							modifyDaemonStatus_ $ \st -> st
+								{ desynced = S.delete u s }
+							addScanRemotes True [r]
+							return True
+						else return False
+
+equivBranches :: Git.Ref -> Git.Ref -> Bool
+equivBranches x y = base x == base y
+  where
+	base = takeFileName . Git.fromRef
+
+isAnnexBranch :: FilePath -> Bool
+isAnnexBranch f = n `isSuffixOf` f
+  where
+	n = '/' : Git.fromRef Annex.Branch.name
+
+fileToBranch :: FilePath -> Git.Ref
+fileToBranch f = Git.Ref $ "refs" </> base
+  where
+	base = Prelude.last $ split "/refs/" f

Assistant/Threads/MountWatcher.hs

@@ -0,0 +1,195 @@
+{- git-annex assistant mount watcher, using either dbus or mtab polling
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Assistant.Threads.MountWatcher where
+
+import Assistant.Common
+import Assistant.DaemonStatus
+import Assistant.Sync
+import qualified Annex
+import qualified Git
+import Utility.ThreadScheduler
+import Utility.Mounts
+import Remote.List
+import qualified Types.Remote as Remote
+import Assistant.Types.UrlRenderer
+import Assistant.Fsck
+
+import qualified Data.Set as S
+
+#if WITH_DBUS
+import Utility.DBus
+import DBus.Client
+import DBus
+import Data.Word (Word32)
+import Control.Concurrent
+import qualified Control.Exception as E
+#else
+#warning Building without dbus support; will use mtab polling
+#endif
+
+mountWatcherThread :: UrlRenderer -> NamedThread
+mountWatcherThread urlrenderer = namedThread "MountWatcher" $
+#if WITH_DBUS
+	dbusThread urlrenderer
+#else
+	pollingThread urlrenderer
+#endif
+
+#if WITH_DBUS
+
+dbusThread :: UrlRenderer -> Assistant ()
+dbusThread urlrenderer = do
+	runclient <- asIO1 go
+	r <- liftIO $ E.try $ runClient getSessionAddress runclient
+	either onerr (const noop) r
+  where
+	go client = ifM (checkMountMonitor client)
+		( do
+			{- Store the current mount points in an MVar, to be
+			 - compared later. We could in theory work out the
+			 - mount point from the dbus message, but this is
+			 - easier. -}
+			mvar <- liftIO $ newMVar =<< currentMountPoints
+			handleevent <- asIO1 $ \_event -> do
+				nowmounted <- liftIO $ currentMountPoints
+				wasmounted <- liftIO $ swapMVar mvar nowmounted
+				handleMounts urlrenderer wasmounted nowmounted
+			liftIO $ forM_ mountChanged $ \matcher ->
+				listen client matcher handleevent
+		, do
+			liftAnnex $
+				warning "No known volume monitor available through dbus; falling back to mtab polling"
+			pollingThread urlrenderer
+		)
+	onerr :: E.SomeException -> Assistant ()
+	onerr e = do
+		{- If the session dbus fails, the user probably
+		 - logged out of their desktop. Even if they log
+		 - back in, we won't have access to the dbus
+		 - session key, so polling is the best that can be
+		 - done in this situation. -}
+		liftAnnex $
+			warning $ "dbus failed; falling back to mtab polling (" ++ show e ++ ")"
+		pollingThread urlrenderer
+
+{- Examine the list of services connected to dbus, to see if there
+ - are any we can use to monitor mounts. If not, will attempt to start one. -}
+checkMountMonitor :: Client -> Assistant Bool
+checkMountMonitor client = do
+	running <- filter (`elem` usableservices)
+		<$> liftIO (listServiceNames client)
+	case running of
+		[] -> startOneService client startableservices
+		(service:_) -> do
+			debug [ "Using running DBUS service"
+				, service
+				, "to monitor mount events."
+				]
+			return True
+  where
+	startableservices = [gvfs, gvfsgdu]
+	usableservices = startableservices ++ [kde]
+	gvfs = "org.gtk.Private.UDisks2VolumeMonitor"
+	gvfsgdu = "org.gtk.Private.GduVolumeMonitor"
+	kde = "org.kde.DeviceNotifications"
+
+startOneService :: Client -> [ServiceName] -> Assistant Bool
+startOneService _ [] = return False
+startOneService client (x:xs) = do
+	_ <- liftIO $ tryNonAsync $ callDBus client "StartServiceByName"
+		[toVariant x, toVariant (0 :: Word32)]
+	ifM (liftIO $ elem x <$> listServiceNames client)
+		( do
+			debug
+				[ "Started DBUS service", x
+				, "to monitor mount events."
+				]
+			return True
+		, startOneService client xs
+		)
+
+{- Filter matching events recieved when drives are mounted and unmounted. -}	
+mountChanged :: [MatchRule]
+mountChanged = [gvfs True, gvfs False, kde, kdefallback]
+  where
+	{- gvfs reliably generates this event whenever a
+	 - drive is mounted/unmounted, whether automatically, or manually -}
+	gvfs mount = matchAny
+		{ matchInterface = Just "org.gtk.Private.RemoteVolumeMonitor"
+		, matchMember = Just $ if mount then "MountAdded" else "MountRemoved"
+		}
+	{- This event fires when KDE prompts the user what to do with a drive,
+	 - but maybe not at other times. And it's not received -}
+	kde = matchAny
+		{ matchInterface = Just "org.kde.Solid.Device"
+		, matchMember = Just "setupDone"
+		}
+	{- This event may not be closely related to mounting a drive, but it's
+	 - observed reliably when a drive gets mounted or unmounted. -}
+	kdefallback = matchAny
+		{ matchInterface = Just "org.kde.KDirNotify"
+		, matchMember = Just "enteredDirectory"
+		}
+
+#endif
+
+pollingThread :: UrlRenderer -> Assistant ()
+pollingThread urlrenderer = go =<< liftIO currentMountPoints
+  where
+	go wasmounted = do
+		liftIO $ threadDelaySeconds (Seconds 10)
+		nowmounted <- liftIO currentMountPoints
+		handleMounts urlrenderer wasmounted nowmounted
+		go nowmounted
+
+handleMounts :: UrlRenderer -> MountPoints -> MountPoints -> Assistant ()
+handleMounts urlrenderer wasmounted nowmounted =
+	mapM_ (handleMount urlrenderer . mnt_dir) $
+		S.toList $ newMountPoints wasmounted nowmounted
+
+handleMount :: UrlRenderer -> FilePath -> Assistant ()
+handleMount urlrenderer dir = do
+	debug ["detected mount of", dir]
+	rs <- filter (Git.repoIsLocal . Remote.repo) <$> remotesUnder dir
+	mapM_ (fsckNudge urlrenderer . Just) rs
+	reconnectRemotes True rs
+
+{- Finds remotes located underneath the mount point.
+ -
+ - Updates state to include the remotes.
+ -
+ - The config of git remotes is re-read, as it may not have been available
+ - at startup time, or may have changed (it could even be a different
+ - repository at the same remote location..)
+ -}
+remotesUnder :: FilePath -> Assistant [Remote]
+remotesUnder dir = do
+	repotop <- liftAnnex $ fromRepo Git.repoPath
+	rs <- liftAnnex remoteList
+	pairs <- liftAnnex $ mapM (checkremote repotop) rs
+	let (waschanged, rs') = unzip pairs
+	when (or waschanged) $ do
+		liftAnnex $ Annex.changeState $ \s -> s { Annex.remotes = catMaybes rs' }
+		updateSyncRemotes
+	return $ mapMaybe snd $ filter fst pairs
+  where
+	checkremote repotop r = case Remote.localpath r of
+		Just p | dirContains dir (absPathFrom repotop p) ->
+			(,) <$> pure True <*> updateRemote r
+		_ -> return (False, Just r)
+
+type MountPoints = S.Set Mntent
+
+currentMountPoints :: IO MountPoints
+currentMountPoints = S.fromList <$> getMounts
+
+newMountPoints :: MountPoints -> MountPoints -> MountPoints
+newMountPoints old new = S.difference new old

Assistant/Threads/NetWatcher.hs

@@ -0,0 +1,140 @@
+{- git-annex assistant network connection watcher, using dbus
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Assistant.Threads.NetWatcher where
+
+import Assistant.Common
+import Assistant.Sync
+import Utility.ThreadScheduler
+import qualified Types.Remote as Remote
+import Assistant.DaemonStatus
+import Utility.NotificationBroadcaster
+
+#if WITH_DBUS
+import Utility.DBus
+import DBus.Client
+import DBus
+import Data.Word (Word32)
+import Assistant.NetMessager
+#else
+#ifdef linux_HOST_OS
+#warning Building without dbus support; will poll for network connection changes
+#endif
+#endif
+
+netWatcherThread :: NamedThread
+#if WITH_DBUS
+netWatcherThread = thread dbusThread
+#else
+netWatcherThread = thread noop
+#endif
+  where
+	thread = namedThread "NetWatcher"
+
+{- This is a fallback for when dbus cannot be used to detect
+ - network connection changes, but it also ensures that
+ - any networked remotes that may have not been routable for a
+ - while (despite the local network staying up), are synced with
+ - periodically.
+ -
+ - Note that it does not call notifyNetMessagerRestart, because
+ - it doesn't know that the network has changed.
+ -}
+netWatcherFallbackThread :: NamedThread
+netWatcherFallbackThread = namedThread "NetWatcherFallback" $
+	runEvery (Seconds 3600) <~> handleConnection
+
+#if WITH_DBUS
+
+dbusThread :: Assistant ()
+dbusThread = do
+	handleerr <- asIO2 onerr
+	runclient <- asIO1 go
+	liftIO $ persistentClient getSystemAddress () handleerr runclient
+  where
+	go client = ifM (checkNetMonitor client)
+		( do
+			listenNMConnections client <~> handleconn
+			listenWicdConnections client <~> handleconn
+		, do
+			liftAnnex $
+				warning "No known network monitor available through dbus; falling back to polling"
+		)
+	handleconn = do
+		debug ["detected network connection"]
+		notifyNetMessagerRestart
+		handleConnection
+	onerr e _ = do
+		liftAnnex $
+			warning $ "lost dbus connection; falling back to polling (" ++ show e ++ ")"
+		{- Wait, in hope that dbus will come back -}
+		liftIO $ threadDelaySeconds (Seconds 60)
+
+{- Examine the list of services connected to dbus, to see if there
+ - are any we can use to monitor network connections. -}
+checkNetMonitor :: Client -> Assistant Bool
+checkNetMonitor client = do
+	running <- liftIO $ filter (`elem` [networkmanager, wicd])
+		<$> listServiceNames client
+	case running of
+		[] -> return False
+		(service:_) -> do
+			debug [ "Using running DBUS service"
+				, service
+				, "to monitor network connection events."
+				]
+			return True
+  where
+	networkmanager = "org.freedesktop.NetworkManager"
+	wicd = "org.wicd.daemon"
+
+{- Listens for new NetworkManager connections. -}
+listenNMConnections :: Client -> IO () -> IO ()
+listenNMConnections client callback =
+	listen client matcher $ \event ->
+		when (Just True == anyM activeconnection (signalBody event)) $
+			callback
+  where
+	matcher = matchAny
+		{ matchInterface = Just "org.freedesktop.NetworkManager.Connection.Active"
+		, matchMember = Just "PropertiesChanged"
+		}
+	nm_connection_activated = toVariant (2 :: Word32)
+	nm_state_key = toVariant ("State" :: String)
+	activeconnection v = do
+		m <- fromVariant v
+		vstate <- lookup nm_state_key $ dictionaryItems m
+		state <- fromVariant vstate
+		return $ state == nm_connection_activated
+
+{- Listens for new Wicd connections. -}
+listenWicdConnections :: Client -> IO () -> IO ()
+listenWicdConnections client callback =
+	listen client matcher $ \event ->
+		when (any (== wicd_success) (signalBody event)) $
+			callback
+  where
+	matcher = matchAny
+		{ matchInterface = Just "org.wicd.daemon"
+		, matchMember = Just "ConnectResultsSent"
+		}
+	wicd_success = toVariant ("success" :: String)
+
+#endif
+
+handleConnection :: Assistant ()
+handleConnection = do
+	liftIO . sendNotification . networkConnectedNotifier =<< getDaemonStatus
+	reconnectRemotes True =<< networkRemotes
+
+{- Network remotes to sync with. -}
+networkRemotes :: Assistant [Remote]
+networkRemotes = filter (isNothing . Remote.localpath) . syncRemotes
+	<$> getDaemonStatus

Assistant/Threads/PairListener.hs

@@ -0,0 +1,160 @@
+{- git-annex assistant thread to listen for incoming pairing traffic
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Assistant.Threads.PairListener where
+
+import Assistant.Common
+import Assistant.Pairing
+import Assistant.Pairing.Network
+import Assistant.Pairing.MakeRemote
+import Assistant.WebApp (UrlRenderer)
+import Assistant.WebApp.Types
+import Assistant.Alert
+import Assistant.DaemonStatus
+import Utility.ThreadScheduler
+import Utility.Format
+import Git
+
+import Network.Multicast
+import Network.Socket
+import qualified Data.Text as T
+import Data.Char
+
+pairListenerThread :: UrlRenderer -> NamedThread
+pairListenerThread urlrenderer = namedThread "PairListener" $ do
+	listener <- asIO1 $ go [] []
+	liftIO $ withSocketsDo $
+		runEvery (Seconds 60) $ void $ tryIO $ 
+			listener =<< getsock
+  where
+	{- Note this can crash if there's no network interface,
+	 - or only one like lo that doesn't support multicast. -}
+	getsock = multicastReceiver (multicastAddress $ IPv4Addr undefined) pairingPort
+		
+	go reqs cache sock = liftIO (getmsg sock []) >>= \msg -> case readish msg of
+		Nothing -> go reqs cache sock
+		Just m -> do
+			debug ["received", show msg]
+			sane <- checkSane msg
+			(pip, verified) <- verificationCheck m
+				=<< (pairingInProgress <$> getDaemonStatus)
+			let wrongstage = maybe False (\p -> pairMsgStage m <= inProgressPairStage p) pip
+			let fromus = maybe False (\p -> remoteSshPubKey (pairMsgData m) == remoteSshPubKey (inProgressPairData p)) pip
+			case (wrongstage, fromus, sane, pairMsgStage m) of
+				(_, True, _, _) -> do
+					debug ["ignoring message that looped back"]
+					go reqs cache sock
+				(_, _, False, _) -> go reqs cache sock
+				-- PairReq starts a pairing process, so a
+				-- new one is always heeded, even if
+				-- some other pairing is in process.
+				(_, _, _, PairReq) -> if m `elem` reqs
+					then go reqs (invalidateCache m cache) sock
+					else do
+						pairReqReceived verified urlrenderer m
+						go (m:take 10 reqs) (invalidateCache m cache) sock
+				(True, _, _, _) -> do
+					debug
+						["ignoring out of order message"
+						, show (pairMsgStage m)
+						, "expected"
+						, show (succ . inProgressPairStage <$> pip)
+						]
+					go reqs cache sock
+				(_, _, _, PairAck) -> do
+					cache' <- pairAckReceived verified pip m cache
+					go reqs cache' sock
+				(_,_ , _, PairDone) -> do
+					pairDoneReceived verified pip m
+					go reqs cache sock
+
+	{- As well as verifying the message using the shared secret,
+	 - check its UUID against the UUID we have stored. If
+	 - they're the same, someone is sending bogus messages,
+	 - which could be an attempt to brute force the shared secret. -}
+	verificationCheck _ Nothing = return (Nothing, False)
+	verificationCheck m (Just pip)
+		| not verified && sameuuid = do
+			liftAnnex $ warning
+				"detected possible pairing brute force attempt; disabled pairing"
+			stopSending pip
+			return (Nothing, False)
+		|otherwise = return (Just pip, verified && sameuuid)
+	  where
+		verified = verifiedPairMsg m pip
+		sameuuid = pairUUID (inProgressPairData pip) == pairUUID (pairMsgData m)
+		
+	checkSane msg
+		{- Control characters could be used in a
+		 - console poisoning attack. -}
+		| any isControl (filter (/= '\n') (decode_c msg)) = do
+			liftAnnex $ warning
+				"illegal control characters in pairing message; ignoring"
+			return False
+		| otherwise = return True
+
+	{- PairReqs invalidate the cache of recently finished pairings.
+	 - This is so that, if a new pairing is started with the
+	 - same secret used before, a bogus PairDone is not sent. -}
+	invalidateCache msg = filter (not . verifiedPairMsg msg)
+
+	getmsg sock c = do
+		(msg, n, _) <- recvFrom sock chunksz
+		if n < chunksz
+			then return $ c ++ msg
+			else getmsg sock $ c ++ msg
+	  where
+		chunksz = 1024
+
+{- Show an alert when a PairReq is seen. -}
+pairReqReceived :: Bool -> UrlRenderer -> PairMsg -> Assistant ()
+pairReqReceived True _ _ = noop -- ignore our own PairReq
+pairReqReceived False urlrenderer msg = do
+	button <- mkAlertButton True (T.pack "Respond") urlrenderer (FinishLocalPairR msg)
+	void $ addAlert $ pairRequestReceivedAlert repo button
+  where
+	repo = pairRepo msg
+
+{- When a verified PairAck is seen, a host is ready to pair with us, and has
+ - already configured our ssh key. Stop sending PairReqs, finish the pairing,
+ - and send a single PairDone. -}
+pairAckReceived :: Bool -> Maybe PairingInProgress -> PairMsg -> [PairingInProgress] -> Assistant [PairingInProgress]
+pairAckReceived True (Just pip) msg cache = do
+	stopSending pip
+	repodir <- repoPath <$> liftAnnex gitRepo
+	liftIO $ setupAuthorizedKeys msg repodir
+	finishedLocalPairing msg (inProgressSshKeyPair pip)
+	startSending pip PairDone $ multicastPairMsg
+		(Just 1) (inProgressSecret pip) (inProgressPairData pip)
+	return $ pip : take 10 cache
+{- A stale PairAck might also be seen, after we've finished pairing.
+ - Perhaps our PairDone was not received. To handle this, we keep
+ - a cache of recently finished pairings, and re-send PairDone in
+ - response to stale PairAcks for them. -}
+pairAckReceived _ _ msg cache = do
+	let pips = filter (verifiedPairMsg msg) cache
+	unless (null pips) $
+		forM_ pips $ \pip ->
+			startSending pip PairDone $ multicastPairMsg
+				(Just 1) (inProgressSecret pip) (inProgressPairData pip)
+	return cache
+
+{- If we get a verified PairDone, the host has accepted our PairAck, and
+ - has paired with us. Stop sending PairAcks, and finish pairing with them.
+ -
+ - TODO: Should third-party hosts remove their pair request alert when they
+ - see a PairDone?
+ - Complication: The user could have already clicked on the alert and be
+ - entering the secret. Would be better to start a fresh pair request in this
+ - situation.
+ -}
+pairDoneReceived :: Bool -> Maybe PairingInProgress -> PairMsg -> Assistant ()
+pairDoneReceived False _ _ = noop -- not verified
+pairDoneReceived True Nothing _ = noop -- not in progress
+pairDoneReceived True (Just pip) msg = do
+	stopSending pip
+	finishedLocalPairing msg (inProgressSshKeyPair pip)

Assistant/Threads/ProblemFixer.hs

@@ -0,0 +1,70 @@
+{- git-annex assistant thread to handle fixing problems with repositories
+ -
+ - Copyright 2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Assistant.Threads.ProblemFixer (
+	problemFixerThread
+) where
+
+import Assistant.Common
+import Assistant.Types.RepoProblem
+import Assistant.RepoProblem
+import Assistant.Types.UrlRenderer
+import Assistant.Alert
+import Remote
+import qualified Types.Remote as Remote
+import qualified Git.Fsck
+import Assistant.Repair
+import qualified Git
+import Annex.UUID
+import Utility.ThreadScheduler
+
+{- Waits for problems with a repo, and tries to fsck the repo and repair
+ - the problem. -}
+problemFixerThread :: UrlRenderer -> NamedThread
+problemFixerThread urlrenderer = namedThread "ProblemFixer" $
+	go =<< getRepoProblems
+  where
+	go problems = do
+		mapM_ (handleProblem urlrenderer) problems
+		liftIO $ threadDelaySeconds (Seconds 60)
+		-- Problems may have been re-reported while they were being
+		-- fixed, so ignore those. If a new unique problem happened
+		-- 60 seconds after the last was fixed, we're unlikely
+		-- to do much good anyway.
+		go =<< filter (\p -> not (any (sameRepoProblem p) problems))
+			<$> getRepoProblems
+
+handleProblem :: UrlRenderer -> RepoProblem -> Assistant ()
+handleProblem urlrenderer repoproblem = do
+	fixed <- ifM ((==) (problemUUID repoproblem) <$> liftAnnex getUUID)
+		( handleLocalRepoProblem urlrenderer
+		, maybe (return False) (handleRemoteProblem urlrenderer)
+			=<< liftAnnex (remoteFromUUID $ problemUUID repoproblem)
+		)
+	when fixed $
+		liftIO $ afterFix repoproblem
+
+handleRemoteProblem :: UrlRenderer -> Remote -> Assistant Bool
+handleRemoteProblem urlrenderer rmt
+	| Git.repoIsLocal r && not (Git.repoIsLocalUnknown r) =
+		ifM (liftIO $ checkAvailable True rmt)
+			( do
+				fixedlocks <- repairStaleGitLocks r
+				fsckresults <- showFscking urlrenderer (Just rmt) $ tryNonAsync $
+					Git.Fsck.findBroken True r
+				repaired <- repairWhenNecessary urlrenderer (Remote.uuid rmt) (Just rmt) fsckresults
+				return $ fixedlocks || repaired
+			, return False
+			)
+	| otherwise = return False
+  where
+	r = Remote.repo rmt
+
+{- This is not yet used, and should probably do a fsck. -}
+handleLocalRepoProblem :: UrlRenderer -> Assistant Bool
+handleLocalRepoProblem _urlrenderer = do
+	repairStaleGitLocks =<< liftAnnex gitRepo

Assistant/Threads/Pusher.hs

@@ -0,0 +1,49 @@
+{- git-annex assistant git pushing thread
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Assistant.Threads.Pusher where
+
+import Assistant.Common
+import Assistant.Commits
+import Assistant.Pushes
+import Assistant.DaemonStatus
+import Assistant.Sync
+import Utility.ThreadScheduler
+import qualified Remote
+import qualified Types.Remote as Remote
+
+{- This thread retries pushes that failed before. -}
+pushRetryThread :: NamedThread
+pushRetryThread = namedThread "PushRetrier" $ runEvery (Seconds halfhour) <~> do
+	-- We already waited half an hour, now wait until there are failed
+	-- pushes to retry.
+	topush <- getFailedPushesBefore (fromIntegral halfhour)
+	unless (null topush) $ do
+		debug ["retrying", show (length topush), "failed pushes"]
+		void $ pushToRemotes True topush
+  where
+	halfhour = 1800
+
+{- This thread pushes git commits out to remotes soon after they are made. -}
+pushThread :: NamedThread
+pushThread = namedThread "Pusher" $ runEvery (Seconds 2) <~> do
+	-- We already waited two seconds as a simple rate limiter.
+	-- Next, wait until at least one commit has been made
+	void getCommits
+	-- Now see if now's a good time to push.
+	void $ pushToRemotes True =<< pushTargets
+
+{- We want to avoid pushing to remotes that are marked readonly.
+ -
+ - Also, avoid pushing to local remotes we can easily tell are not available,
+ - to avoid ugly messages when a removable drive is not attached.
+ -}
+pushTargets :: Assistant [Remote]
+pushTargets = liftIO . filterM (Remote.checkAvailable True)
+	=<< candidates <$> getDaemonStatus
+  where
+	candidates = filter (not . Remote.readonly) . syncGitRemotes

Assistant/Threads/SanityChecker.hs

@@ -0,0 +1,260 @@
+{- git-annex assistant sanity checker
+ -
+ - Copyright 2012, 2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE CPP #-}
+
+module Assistant.Threads.SanityChecker (
+	sanityCheckerStartupThread,
+	sanityCheckerDailyThread,
+	sanityCheckerHourlyThread
+) where
+
+import Assistant.Common
+import Assistant.DaemonStatus
+import Assistant.Alert
+import Assistant.Repair
+import Assistant.Drop
+import Assistant.Ssh
+import Assistant.TransferQueue
+import Assistant.Types.UrlRenderer
+import qualified Annex.Branch
+import qualified Git.LsFiles
+import qualified Git.Command
+import qualified Git.Config
+import Utility.ThreadScheduler
+import qualified Assistant.Threads.Watcher as Watcher
+import Utility.Batch
+import Utility.NotificationBroadcaster
+import Config
+import Utility.HumanTime
+import Utility.Tense
+import Git.Repair
+import Git.Index
+import Assistant.Unused
+import Logs.Unused
+import Logs.Transfer
+import Config.Files
+import Utility.DiskFree
+import qualified Annex
+#ifdef WITH_WEBAPP
+import Assistant.WebApp.Types
+#endif
+#ifndef mingw32_HOST_OS
+import Utility.LogFile
+#endif
+
+import Data.Time.Clock.POSIX
+import qualified Data.Text as T
+
+{- This thread runs once at startup, and most other threads wait for it
+ - to finish. (However, the webapp thread does not, to prevent the UI
+ - being nonresponsive.) -}
+sanityCheckerStartupThread :: Maybe Duration -> NamedThread
+sanityCheckerStartupThread startupdelay = namedThreadUnchecked "SanityCheckerStartup" $ do
+	{- Stale git locks can prevent commits from happening, etc. -}
+	void $ repairStaleGitLocks =<< liftAnnex gitRepo
+
+	{- A corrupt index file can prevent the assistant from working at
+	 - all, so detect and repair. -}
+	ifM (not <$> liftAnnex (inRepo checkIndexFast))
+		( do
+			notice ["corrupt index file found at startup; removing and restaging"]
+			liftAnnex $ inRepo $ nukeFile . indexFile
+			{- Normally the startup scan avoids re-staging files,
+			 - but with the index deleted, everything needs to be
+			 - restaged. -}
+			modifyDaemonStatus_ $ \s -> s { forceRestage = True }
+		, whenM (liftAnnex $ inRepo missingIndex) $ do
+			debug ["no index file; restaging"]
+			modifyDaemonStatus_ $ \s -> s { forceRestage = True }
+		)
+	{- If the git-annex index file is corrupt, it's ok to remove it;
+	 - the data from the git-annex branch will be used, and the index
+	 - will be automatically regenerated. -}
+	unlessM (liftAnnex $ Annex.Branch.withIndex $ inRepo $ Git.Repair.checkIndexFast) $ do
+		notice ["corrupt annex/index file found at startup; removing"]
+		liftAnnex $ liftIO . nukeFile =<< fromRepo gitAnnexIndex
+
+	{- Fix up ssh remotes set up by past versions of the assistant. -}
+	liftIO $ fixUpSshRemotes
+
+	{- If there's a startup delay, it's done here. -}
+	liftIO $ maybe noop (threadDelaySeconds . Seconds . fromIntegral . durationSeconds) startupdelay
+
+	{- Notify other threads that the startup sanity check is done. -}
+	status <- getDaemonStatus
+	liftIO $ sendNotification $ startupSanityCheckNotifier status
+
+{- This thread wakes up hourly for inxepensive frequent sanity checks. -}
+sanityCheckerHourlyThread :: NamedThread
+sanityCheckerHourlyThread = namedThread "SanityCheckerHourly" $ forever $ do
+	liftIO $ threadDelaySeconds $ Seconds oneHour
+	hourlyCheck
+
+{- This thread wakes up daily to make sure the tree is in good shape. -}
+sanityCheckerDailyThread :: UrlRenderer -> NamedThread
+sanityCheckerDailyThread urlrenderer = namedThread "SanityCheckerDaily" $ forever $ do
+	waitForNextCheck
+
+	debug ["starting sanity check"]
+	void $ alertWhile sanityCheckAlert go
+	debug ["sanity check complete"]
+  where
+	go = do
+		modifyDaemonStatus_ $ \s -> s { sanityCheckRunning = True }
+
+		now <- liftIO getPOSIXTime -- before check started
+		r <- either showerr return 
+			=<< (tryIO . batch) <~> dailyCheck urlrenderer
+
+		modifyDaemonStatus_ $ \s -> s
+			{ sanityCheckRunning = False
+			, lastSanityCheck = Just now
+			}
+
+		return r
+
+	showerr e = do
+		liftAnnex $ warning $ show e
+		return False
+
+{- Only run one check per day, from the time of the last check. -}
+waitForNextCheck :: Assistant ()
+waitForNextCheck = do
+	v <- lastSanityCheck <$> getDaemonStatus
+	now <- liftIO getPOSIXTime
+	liftIO $ threadDelaySeconds $ Seconds $ calcdelay now v
+  where
+	calcdelay _ Nothing = oneDay
+	calcdelay now (Just lastcheck)
+		| lastcheck < now = max oneDay $
+			oneDay - truncate (now - lastcheck)
+		| otherwise = oneDay
+
+{- It's important to stay out of the Annex monad as much as possible while
+ - running potentially expensive parts of this check, since remaining in it
+ - will block the watcher. -}
+dailyCheck :: UrlRenderer -> Assistant Bool
+dailyCheck urlrenderer = do
+	g <- liftAnnex gitRepo
+	batchmaker <- liftIO getBatchCommandMaker
+
+	-- Find old unstaged symlinks, and add them to git.
+	(unstaged, cleanup) <- liftIO $ Git.LsFiles.notInRepo False ["."] g
+	now <- liftIO getPOSIXTime
+	forM_ unstaged $ \file -> do
+		ms <- liftIO $ catchMaybeIO $ getSymbolicLinkStatus file
+		case ms of
+			Just s	| toonew (statusChangeTime s) now -> noop
+				| isSymbolicLink s -> addsymlink file ms
+			_ -> noop
+	liftIO $ void cleanup
+
+	{- Allow git-gc to run once per day. More frequent gc is avoided
+	 - by default to avoid slowing things down. Only run repacks when 100x
+	 - the usual number of loose objects are present; we tend
+	 - to have a lot of small objects and they should not be a
+	 - significant size. -}
+	when (Git.Config.getMaybe "gc.auto" g == Just "0") $
+		liftIO $ void $ Git.Command.runBatch batchmaker
+			[ Param "-c", Param "gc.auto=670000"
+			, Param "gc"
+			, Param "--auto"
+			] g
+
+	{- Check if the unused files found last time have been dealt with. -}
+	checkOldUnused urlrenderer
+
+	{- Run git-annex unused once per day. This is run as a separate
+	 - process to stay out of the annex monad and so it can run as a
+	 - batch job. -}
+	program <- liftIO readProgramFile
+	let (program', params') = batchmaker (program, [Param "unused"])
+	void $ liftIO $ boolSystem program' params'
+	{- Invalidate unused keys cache, and queue transfers of all unused
+	 - keys, or if no transfers are called for, drop them. -}
+	unused <- liftAnnex unusedKeys'
+	void $ liftAnnex $ setUnusedKeys unused
+	forM_ unused $ \k -> do
+		unlessM (queueTransfers "unused" Later k Nothing Upload) $
+			handleDrops "unused" True k Nothing Nothing
+
+	return True
+  where
+	toonew timestamp now = now < (realToFrac (timestamp + slop) :: POSIXTime)
+	slop = fromIntegral tenMinutes
+	insanity msg = do
+		liftAnnex $ warning msg
+		void $ addAlert $ sanityCheckFixAlert msg
+	addsymlink file s = do
+		isdirect <- liftAnnex isDirect
+		Watcher.runHandler (Watcher.onAddSymlink isdirect) file s
+		insanity $ "found unstaged symlink: " ++ file
+
+hourlyCheck :: Assistant ()
+hourlyCheck = do
+#ifndef mingw32_HOST_OS
+	checkLogSize 0
+#else
+	noop
+#endif
+
+#ifndef mingw32_HOST_OS
+{- Rotate logs once when total log file size is > 2 mb.
+ -
+ - If total log size is larger than the amount of free disk space,
+ - continue rotating logs until size is < 2 mb, even if this
+ - results in immediately losing the just logged data.
+ -}
+checkLogSize :: Int -> Assistant ()
+checkLogSize n = do
+	f <- liftAnnex $ fromRepo gitAnnexLogFile
+	logs <- liftIO $ listLogs f
+	totalsize <- liftIO $ sum <$> mapM filesize logs
+	when (totalsize > 2 * oneMegabyte) $ do
+		notice ["Rotated logs due to size:", show totalsize]
+		liftIO $ openLog f >>= redirLog
+		when (n < maxLogs + 1) $ do
+			df <- liftIO $ getDiskFree $ takeDirectory f
+			case df of
+				Just free
+					| free < fromIntegral totalsize ->
+						checkLogSize (n + 1)
+				_ -> noop
+  where
+	filesize f = fromIntegral . fileSize <$> liftIO (getFileStatus f)
+
+	oneMegabyte :: Int
+	oneMegabyte = 1000000
+#endif
+
+oneHour :: Int
+oneHour = 60 * 60
+
+oneDay :: Int
+oneDay = 24 * oneHour
+
+{- If annex.expireunused is set, find any keys that have lingered unused
+ - for the specified duration, and remove them.
+ -
+ - Otherwise, check to see if unused keys are piling up, and let the user
+ - know. -}
+checkOldUnused :: UrlRenderer -> Assistant ()
+checkOldUnused urlrenderer = go =<< annexExpireUnused <$> liftAnnex Annex.getGitConfig
+  where
+	go (Just Nothing) = noop
+  	go (Just (Just expireunused)) = expireUnused (Just expireunused)
+	go Nothing = maybe noop prompt =<< describeUnusedWhenBig
+
+	prompt msg = 
+#ifdef WITH_WEBAPP
+		do
+			button <- mkAlertButton True (T.pack "Configure") urlrenderer ConfigUnusedR
+			void $ addAlert $ unusedFilesAlert [button] $ T.unpack $ renderTense Present msg
+#else
+		debug [show $ renderTense Past msg]
+#endif

Assistant/Threads/TransferPoller.hs

@@ -0,0 +1,56 @@
+{- git-annex assistant transfer polling thread
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Assistant.Threads.TransferPoller where
+
+import Assistant.Common
+import Assistant.DaemonStatus
+import Logs.Transfer
+import Utility.NotificationBroadcaster
+import qualified Assistant.Threads.TransferWatcher as TransferWatcher
+
+import Control.Concurrent
+import qualified Data.Map as M
+
+{- This thread polls the status of ongoing transfers, determining how much
+ - of each transfer is complete. -}
+transferPollerThread :: NamedThread
+transferPollerThread = namedThread "TransferPoller" $ do
+	g <- liftAnnex gitRepo
+	tn <- liftIO . newNotificationHandle True =<<
+		transferNotifier <$> getDaemonStatus
+	forever $ do
+		liftIO $ threadDelay 500000 -- 0.5 seconds
+		ts <- currentTransfers <$> getDaemonStatus
+		if M.null ts
+			-- block until transfers running
+			then liftIO $ waitNotification tn
+			else mapM_ (poll g) $ M.toList ts
+  where
+	poll g (t, info)
+		{- Downloads are polled by checking the size of the
+		 - temp file being used for the transfer. -}
+		| transferDirection t == Download = do
+			let f = gitAnnexTmpObjectLocation (transferKey t) g
+			sz <- liftIO $ catchMaybeIO $
+				fromIntegral . fileSize <$> getFileStatus f
+			newsize t info sz
+		{- Uploads don't need to be polled for when the TransferWatcher
+		 - thread can track file modifications. -}
+		| TransferWatcher.watchesTransferSize = noop
+		{- Otherwise, this code polls the upload progress
+		 - by reading the transfer info file. -}
+		| otherwise = do
+			let f = transferFile t g
+			mi <- liftIO $ catchDefaultIO Nothing $
+				readTransferInfoFile Nothing f
+			maybe noop (newsize t info . bytesComplete) mi
+
+	newsize t info sz
+		| bytesComplete info /= sz && isJust sz =
+			alterTransferInfo t $ \i -> i { bytesComplete = sz }
+		| otherwise = noop

Assistant/Threads/TransferScanner.hs

@@ -0,0 +1,184 @@
+{- git-annex assistant thread to scan remotes to find needed transfers
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Assistant.Threads.TransferScanner where
+
+import Assistant.Common
+import Assistant.Types.ScanRemotes
+import Assistant.ScanRemotes
+import Assistant.TransferQueue
+import Assistant.DaemonStatus
+import Assistant.Drop
+import Assistant.Sync
+import Assistant.DeleteRemote
+import Assistant.Types.UrlRenderer
+import Logs.Transfer
+import Logs.Location
+import Logs.Group
+import Logs.Web (webUUID)
+import qualified Remote
+import qualified Types.Remote as Remote
+import Utility.ThreadScheduler
+import Utility.NotificationBroadcaster
+import Utility.Batch
+import qualified Git.LsFiles as LsFiles
+import qualified Backend
+import Annex.Content
+import Annex.Wanted
+import CmdLine.Action
+
+import qualified Data.Set as S
+
+{- This thread waits until a remote needs to be scanned, to find transfers
+ - that need to be made, to keep data in sync.
+ -}
+transferScannerThread :: UrlRenderer -> NamedThread
+transferScannerThread urlrenderer = namedThread "TransferScanner" $ do
+	startupScan
+	go S.empty
+  where
+	go scanned = do
+		scanrunning False
+		liftIO $ threadDelaySeconds (Seconds 2)
+		(rs, infos) <- unzip <$> getScanRemote
+		scanrunning True
+		if any fullScan infos || any (`S.notMember` scanned) rs
+			then do
+				expensiveScan urlrenderer rs
+				go $ scanned `S.union` S.fromList rs
+			else do
+				mapM_ failedTransferScan rs
+				go scanned
+	scanrunning b = do
+		ds <- modifyDaemonStatus $ \s -> 
+			(s { transferScanRunning = b }, s)
+		liftIO $ sendNotification $ transferNotifier ds
+		
+	{- All git remotes are synced, and all available remotes
+	 - are scanned in full on startup, for multiple reasons, including:
+	 -
+	 - * This may be the first run, and there may be remotes
+	 -   already in place, that need to be synced.
+	 - * Changes may have been made last time we run, but remotes were
+	 -   not available to be synced with.
+	 - * Changes may have been made to remotes while we were down.
+	 - * We may have run before, and scanned a remote, but
+	 -   only been in a subdirectory of the git remote, and so
+	 -   not synced it all.
+	 - * We may have run before, and had transfers queued,
+	 -   and then the system (or us) crashed, and that info was
+	 -   lost.
+	 - * A remote may be in the unwanted group, and this is a chance
+	 -   to determine if the remote has been emptied.
+	 -}
+	startupScan = do
+		reconnectRemotes True =<< syncGitRemotes <$> getDaemonStatus
+		addScanRemotes True =<< syncDataRemotes <$> getDaemonStatus
+
+{- This is a cheap scan for failed transfers involving a remote. -}
+failedTransferScan :: Remote -> Assistant ()
+failedTransferScan r = do
+	failed <- liftAnnex $ clearFailedTransfers (Remote.uuid r)
+	mapM_ retry failed
+  where
+	retry (t, info)
+		| transferDirection t == Download =
+			{- Check if the remote still has the key.
+			 - If not, relies on the expensiveScan to
+			 - get it queued from some other remote. -}
+			whenM (liftAnnex $ remoteHas r $ transferKey t) $
+				requeue t info
+		| otherwise =
+			{- The Transferrer checks when uploading
+			 - that the remote doesn't already have the
+			 - key, so it's not redundantly checked here. -}
+			requeue t info
+	requeue t info = queueTransferWhenSmall "retrying failed transfer" (associatedFile info) t r
+	
+{- This is a expensive scan through the full git work tree, finding
+ - files to transfer. The scan is blocked when the transfer queue gets
+ - too large. 
+ -
+ - This also finds files that are present either here or on a remote
+ - but that are not preferred content, and drops them. Searching for files
+ - to drop is done concurrently with the scan for transfers.
+ -
+ - TODO: It would be better to first drop as much as we can, before
+ - transferring much, to minimise disk use.
+ - 
+ - During the scan, we'll also check if any unwanted repositories are empty,
+ - and can be removed. While unrelated, this is a cheap place to do it,
+ - since we need to look at the locations of all keys anyway.
+ -}
+expensiveScan :: UrlRenderer -> [Remote] -> Assistant ()
+expensiveScan urlrenderer rs = unless onlyweb $ batch <~> do
+	debug ["starting scan of", show visiblers]
+
+	let us = map Remote.uuid rs
+
+	mapM_ (liftAnnex . clearFailedTransfers) us
+
+	unwantedrs <- liftAnnex $ S.fromList
+		<$> filterM inUnwantedGroup us
+
+	g <- liftAnnex gitRepo
+	(files, cleanup) <- liftIO $ LsFiles.inRepo [] g
+	removablers <- scan unwantedrs files
+	void $ liftIO cleanup
+
+	debug ["finished scan of", show visiblers]
+
+	remove <- asIO1 $ removableRemote urlrenderer
+	liftIO $ mapM_ (void . tryNonAsync . remove) $ S.toList removablers
+  where
+	onlyweb = all (== webUUID) $ map Remote.uuid rs
+	visiblers = let rs' = filter (not . Remote.readonly) rs
+		in if null rs' then rs else rs'
+
+	scan unwanted [] = return unwanted
+	scan unwanted (f:fs) = do
+		(unwanted', ts) <- maybe
+			(return (unwanted, []))
+			(findtransfers f unwanted)
+				=<< liftAnnex (Backend.lookupFile f)
+		mapM_ (enqueue f) ts
+		scan unwanted' fs
+
+	enqueue f (r, t) =
+		queueTransferWhenSmall "expensive scan found missing object"
+			(Just f) t r
+	findtransfers f unwanted (key, _) = do
+		{- The syncable remotes may have changed since this
+		 - scan began. -}
+		syncrs <- syncDataRemotes <$> getDaemonStatus
+		locs <- liftAnnex $ loggedLocations key
+		present <- liftAnnex $ inAnnex key
+		liftAnnex $ handleDropsFrom locs syncrs
+			"expensive scan found too many copies of object"
+			present key (Just f) Nothing callCommandAction
+		liftAnnex $ do
+			let slocs = S.fromList locs
+			let use a = return $ mapMaybe (a key slocs) syncrs
+			ts <- if present
+				then filterM (wantSend True (Just key) (Just f) . Remote.uuid . fst)
+					=<< use (genTransfer Upload False)
+				else ifM (wantGet True (Just key) (Just f))
+					( use (genTransfer Download True) , return [] )
+			let unwanted' = S.difference unwanted slocs
+			return (unwanted', ts)
+
+genTransfer :: Direction -> Bool -> Key -> S.Set UUID -> Remote -> Maybe (Remote, Transfer)
+genTransfer direction want key slocs r
+	| direction == Upload && Remote.readonly r = Nothing
+	| S.member (Remote.uuid r) slocs == want = Just
+		(r, Transfer direction (Remote.uuid r) key)
+	| otherwise = Nothing
+
+remoteHas :: Remote -> Key -> Annex Bool
+remoteHas r key = elem
+	<$> pure (Remote.uuid r)
+	<*> loggedLocations key

Assistant/Threads/TransferWatcher.hs

@@ -0,0 +1,104 @@
+{- git-annex assistant transfer watching thread
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Assistant.Threads.TransferWatcher where
+
+import Assistant.Common
+import Assistant.DaemonStatus
+import Assistant.TransferSlots
+import Logs.Transfer
+import Utility.DirWatcher
+import Utility.DirWatcher.Types
+import qualified Remote
+
+import Control.Concurrent
+import qualified Data.Map as M
+
+{- This thread watches for changes to the gitAnnexTransferDir,
+ - and updates the DaemonStatus's map of ongoing transfers. -}
+transferWatcherThread :: NamedThread
+transferWatcherThread = namedThread "TransferWatcher" $ do
+	dir <- liftAnnex $ gitAnnexTransferDir <$> gitRepo
+	liftIO $ createDirectoryIfMissing True dir
+	let hook a = Just <$> asIO2 (runHandler a)
+	addhook <- hook onAdd
+	delhook <- hook onDel
+	modifyhook <- hook onModify
+	errhook <- hook onErr
+	let hooks = mkWatchHooks
+		{ addHook = addhook
+		, delHook = delhook
+		, modifyHook = modifyhook
+		, errHook = errhook
+		}
+	void $ liftIO $ watchDir dir (const False) True hooks id
+	debug ["watching for transfers"]
+
+type Handler = FilePath -> Assistant ()
+
+{- Runs an action handler.
+ -
+ - Exceptions are ignored, otherwise a whole thread could be crashed.
+ -}
+runHandler :: Handler -> FilePath -> Maybe FileStatus -> Assistant ()
+runHandler handler file _filestatus =
+	either (liftIO . print) (const noop) =<< tryIO <~> handler file
+
+{- Called when there's an error with inotify. -}
+onErr :: Handler
+onErr = error
+
+{- Called when a new transfer information file is written. -}
+onAdd :: Handler
+onAdd file = case parseTransferFile file of
+	Nothing -> noop
+	Just t -> go t =<< liftAnnex (checkTransfer t)
+  where
+	go _ Nothing = noop -- transfer already finished
+	go t (Just info) = do
+		debug [ "transfer starting:", describeTransfer t info ]
+		r <- liftAnnex $ Remote.remoteFromUUID $ transferUUID t
+		updateTransferInfo t info { transferRemote = r }
+
+{- Called when a transfer information file is updated.
+ -
+ - The only thing that should change in the transfer info is the
+ - bytesComplete, so that's the only thing updated in the DaemonStatus. -}
+onModify :: Handler
+onModify file = case parseTransferFile file of
+	Nothing -> noop
+	Just t -> go t =<< liftIO (readTransferInfoFile Nothing file)
+  where
+	go _ Nothing = noop
+	go t (Just newinfo) = alterTransferInfo t $
+		\i -> i { bytesComplete = bytesComplete newinfo }
+
+{- This thread can only watch transfer sizes when the DirWatcher supports
+ - tracking modificatons to files. -}
+watchesTransferSize :: Bool
+watchesTransferSize = modifyTracked
+
+{- Called when a transfer information file is removed. -}
+onDel :: Handler
+onDel file = case parseTransferFile file of
+	Nothing -> noop
+	Just t -> do
+		debug [ "transfer finishing:", show t]
+		minfo <- removeTransfer t
+
+		-- Run transfer hook.
+		m <- transferHook <$> getDaemonStatus
+		maybe noop (\hook -> void $ liftIO $ forkIO $ hook t)
+			(M.lookup (transferKey t) m)
+
+		finished <- asIO2 finishedTransfer
+		void $ liftIO $ forkIO $ do
+			{- XXX race workaround delay. The location
+			 - log needs to be updated before finishedTransfer
+			 - runs. -}
+			threadDelay 10000000 -- 10 seconds
+			finished t minfo

Assistant/Threads/Transferrer.hs

@@ -0,0 +1,27 @@
+{- git-annex assistant data transferrer thread
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Assistant.Threads.Transferrer where
+
+import Assistant.Common
+import Assistant.TransferQueue
+import Assistant.TransferSlots
+import Logs.Transfer
+import Config.Files
+import Utility.Batch
+
+{- Dispatches transfers from the queue. -}
+transfererThread :: NamedThread
+transfererThread = namedThread "Transferrer" $ do
+	program <- liftIO readProgramFile
+	batchmaker <- liftIO getBatchCommandMaker
+	forever $ inTransferSlot program batchmaker $
+		maybe (return Nothing) (uncurry genTransfer)
+			=<< getNextTransfer notrunning
+  where
+	{- Skip transfers that are already running. -}
+	notrunning = isNothing . startedTime

Assistant/Threads/UpgradeWatcher.hs

@@ -0,0 +1,110 @@
+{- git-annex assistant thread to detect when git-annex is upgraded
+ -
+ - Copyright 2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE CPP #-}
+
+module Assistant.Threads.UpgradeWatcher (
+	upgradeWatcherThread
+) where
+
+import Assistant.Common
+import Assistant.Upgrade
+import Utility.DirWatcher
+import Utility.DirWatcher.Types
+import Utility.ThreadScheduler
+import Assistant.Types.UrlRenderer
+import Assistant.Alert
+import Assistant.DaemonStatus
+#ifdef WITH_WEBAPP
+import Assistant.WebApp.Types
+import qualified Build.SysConfig
+#endif
+
+import Control.Concurrent.MVar
+import qualified Data.Text as T
+
+data WatcherState = InStartupScan | Started | Upgrading
+	deriving (Eq)
+
+upgradeWatcherThread :: UrlRenderer -> NamedThread
+upgradeWatcherThread urlrenderer = namedThread "UpgradeWatcher" $ do
+	whenM (liftIO checkSuccessfulUpgrade) $
+		showSuccessfulUpgrade urlrenderer
+	go =<< liftIO upgradeFlagFile
+  where
+	go Nothing = debug [ "cannot determine program path" ]
+	go (Just flagfile) = do
+		mvar <- liftIO $ newMVar InStartupScan
+		changed <- Just <$> asIO2 (changedFile urlrenderer mvar flagfile)
+		let hooks = mkWatchHooks
+			{ addHook = changed
+			, delHook = changed
+			, addSymlinkHook = changed
+			, modifyHook = changed
+			, delDirHook = changed
+			}
+		let dir = parentDir flagfile
+		let depth = length (splitPath dir) + 1
+		let nosubdirs f = length (splitPath f) == depth
+		void $ liftIO $ watchDir dir nosubdirs False hooks (startup mvar)
+  	-- Ignore bogus events generated during the startup scan.
+	-- We ask the watcher to not generate them, but just to be safe..
+  	startup mvar scanner = do
+		r <- scanner
+		void $ swapMVar mvar Started
+		return r
+
+changedFile :: UrlRenderer -> MVar WatcherState -> FilePath -> FilePath -> Maybe FileStatus -> Assistant ()
+changedFile urlrenderer mvar flagfile file _status
+	| flagfile /= file = noop
+	| otherwise = do
+		state <- liftIO $ readMVar mvar
+		when (state == Started) $ do
+			setstate Upgrading
+			ifM (liftIO upgradeSanityCheck)
+				( handleUpgrade urlrenderer
+				, do
+					debug ["new version failed sanity check; not using"]
+					setstate Started
+				)
+  where
+	setstate = void . liftIO . swapMVar mvar
+
+handleUpgrade :: UrlRenderer -> Assistant ()
+handleUpgrade urlrenderer = do
+	-- Wait 2 minutes for any final upgrade changes to settle.
+	-- (For example, other associated files may be being put into
+	-- place.) Not needed when using a distribution bundle, because
+	-- in that case git-annex handles the upgrade in a non-racy way.
+	liftIO $ unlessM usingDistribution $
+		threadDelaySeconds (Seconds 120)
+	ifM autoUpgradeEnabled
+		( do
+			debug ["starting automatic upgrade"]
+			unattendedUpgrade
+#ifdef WITH_WEBAPP
+		, do
+			button <- mkAlertButton True (T.pack "Finish Upgrade") urlrenderer ConfigFinishUpgradeR
+			void $ addAlert $ upgradeReadyAlert button
+#else
+		, noop
+#endif
+		)
+
+showSuccessfulUpgrade :: UrlRenderer -> Assistant ()
+showSuccessfulUpgrade urlrenderer = do
+#ifdef WITH_WEBAPP
+	button <- ifM autoUpgradeEnabled 
+		( pure Nothing
+		, Just <$> mkAlertButton True
+			(T.pack "Enable Automatic Upgrades")
+			urlrenderer ConfigEnableAutomaticUpgradeR
+		)
+	void $ addAlert $ upgradeFinishedAlert button Build.SysConfig.packageversion
+#else
+	noop
+#endif

Assistant/Threads/Upgrader.hs

@@ -0,0 +1,101 @@
+{- git-annex assistant thread to detect when upgrade is available
+ -
+ - Copyright 2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE CPP #-}
+
+module Assistant.Threads.Upgrader (
+	upgraderThread
+) where
+
+import Assistant.Common
+import Assistant.Upgrade
+
+import Assistant.Types.UrlRenderer
+import Assistant.DaemonStatus
+import Assistant.Alert
+import Utility.NotificationBroadcaster
+import Utility.Tmp
+import qualified Annex
+import qualified Build.SysConfig
+import qualified Utility.Url as Url
+import qualified Annex.Url as Url
+import qualified Git.Version
+import Types.Distribution
+#ifdef WITH_WEBAPP
+import Assistant.WebApp.Types
+#endif
+
+import Data.Time.Clock
+import qualified Data.Text as T
+
+upgraderThread :: UrlRenderer -> NamedThread
+upgraderThread urlrenderer = namedThread "Upgrader" $
+	when (isJust Build.SysConfig.upgradelocation) $ do
+		{- Check for upgrade on startup, unless it was just
+		 - upgraded. -}
+		unlessM (liftIO checkSuccessfulUpgrade) $
+			checkUpgrade urlrenderer
+		h <- liftIO . newNotificationHandle False . networkConnectedNotifier =<< getDaemonStatus
+		go h =<< liftIO getCurrentTime
+  where
+  	{- Wait for a network connection event. Then see if it's been
+	 - half a day since the last upgrade check. If so, proceed with
+	 - check. -}
+	go h lastchecked = do
+		liftIO $ waitNotification h
+		autoupgrade <- liftAnnex $ annexAutoUpgrade <$> Annex.getGitConfig
+		if autoupgrade == NoAutoUpgrade
+			then go h lastchecked
+			else do
+				now <- liftIO getCurrentTime
+				if diffUTCTime now lastchecked > halfday
+					then do
+						checkUpgrade urlrenderer
+						go h =<< liftIO getCurrentTime
+					else go h lastchecked
+	halfday = 12 * 60 * 60
+
+checkUpgrade :: UrlRenderer -> Assistant ()
+checkUpgrade urlrenderer = do
+	debug [ "Checking if an upgrade is available." ]
+	go =<< getDistributionInfo
+  where
+	go Nothing = debug [ "Failed to check if upgrade is available." ]
+	go (Just d) = do
+		let installed = Git.Version.normalize Build.SysConfig.packageversion
+		let avail = Git.Version.normalize $ distributionVersion d
+		let old = Git.Version.normalize <$> distributionUrgentUpgrade d
+		if Just installed <= old
+			then canUpgrade High urlrenderer d
+			else if installed < avail
+				then canUpgrade Low urlrenderer d
+				else debug [ "No new version found." ]
+
+canUpgrade :: AlertPriority -> UrlRenderer -> GitAnnexDistribution -> Assistant ()
+canUpgrade urgency urlrenderer d = ifM autoUpgradeEnabled
+	( startDistributionDownload d
+	, do
+#ifdef WITH_WEBAPP
+		button <- mkAlertButton True (T.pack "Upgrade") urlrenderer (ConfigStartUpgradeR d)
+		void $ addAlert (canUpgradeAlert urgency (distributionVersion d) button)
+#else
+		noop
+#endif
+	)
+
+getDistributionInfo :: Assistant (Maybe GitAnnexDistribution)
+getDistributionInfo = do
+	uo <- liftAnnex Url.getUrlOptions
+	liftIO $ withTmpFile "git-annex.tmp" $ \tmpfile h -> do
+		hClose h
+		ifM (Url.downloadQuiet distributionInfoUrl tmpfile uo)
+			( readish <$> readFileStrict tmpfile
+			, return Nothing
+			)
+
+distributionInfoUrl :: String
+distributionInfoUrl = fromJust Build.SysConfig.upgradelocation ++ ".info"

Assistant/Threads/Watcher.hs

@@ -0,0 +1,368 @@
+{- git-annex assistant tree watcher
+ -
+ - Copyright 2012-2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE DeriveDataTypeable, CPP #-}
+
+module Assistant.Threads.Watcher (
+	watchThread,
+	WatcherControl(..),
+	checkCanWatch,
+	needLsof,
+	onAddSymlink,
+	runHandler,
+) where
+
+import Assistant.Common
+import Assistant.DaemonStatus
+import Assistant.Changes
+import Assistant.Types.Changes
+import Assistant.Alert
+import Utility.DirWatcher
+import Utility.DirWatcher.Types
+import qualified Annex
+import qualified Annex.Queue
+import qualified Git
+import qualified Git.UpdateIndex
+import qualified Git.LsFiles as LsFiles
+import qualified Backend
+import Annex.Direct
+import Annex.Content.Direct
+import Annex.CatFile
+import Annex.CheckIgnore
+import Annex.Link
+import Annex.FileMatcher
+import Types.FileMatcher
+import Annex.ReplaceFile
+import Git.Types
+import Config
+import Utility.ThreadScheduler
+#ifndef mingw32_HOST_OS
+import qualified Utility.Lsof as Lsof
+#endif
+
+import Data.Bits.Utils
+import Data.Typeable
+import qualified Data.ByteString.Lazy as L
+import qualified Control.Exception as E
+import Data.Time.Clock
+
+checkCanWatch :: Annex ()
+checkCanWatch
+	| canWatch = do
+#ifndef mingw32_HOST_OS
+		liftIO Lsof.setup
+		unlessM (liftIO (inPath "lsof") <||> Annex.getState Annex.force)
+			needLsof
+#else
+		noop
+#endif
+	| otherwise = error "watch mode is not available on this system"
+
+needLsof :: Annex ()
+needLsof = error $ unlines
+	[ "The lsof command is needed for watch mode to be safe, and is not in PATH."
+	, "To override lsof checks to ensure that files are not open for writing"
+	, "when added to the annex, you can use --force"
+	, "Be warned: This can corrupt data in the annex, and make fsck complain."
+	]
+
+{- A special exception that can be thrown to pause or resume the watcher. -}
+data WatcherControl = PauseWatcher | ResumeWatcher
+        deriving (Show, Eq, Typeable)
+
+instance E.Exception WatcherControl
+
+watchThread :: NamedThread
+watchThread = namedThread "Watcher" $
+	ifM (liftAnnex $ annexAutoCommit <$> Annex.getGitConfig)
+		( runWatcher
+		, waitFor ResumeWatcher runWatcher
+		)
+
+runWatcher :: Assistant ()
+runWatcher = do
+	startup <- asIO1 startupScan
+	matcher <- liftAnnex largeFilesMatcher
+	direct <- liftAnnex isDirect
+	symlinkssupported <- liftAnnex $ coreSymlinks <$> Annex.getGitConfig
+	addhook <- hook $ if direct
+		then onAddDirect symlinkssupported matcher
+		else onAdd matcher
+	delhook <- hook onDel
+	addsymlinkhook <- hook $ onAddSymlink direct
+	deldirhook <- hook onDelDir
+	errhook <- hook onErr
+	let hooks = mkWatchHooks
+		{ addHook = addhook
+		, delHook = delhook
+		, addSymlinkHook = addsymlinkhook
+		, delDirHook = deldirhook
+		, errHook = errhook
+		}
+	scanevents <- liftAnnex $ annexStartupScan <$> Annex.getGitConfig
+	handle <- liftIO $ watchDir "." ignored scanevents hooks startup
+	debug [ "watching", "."]
+	
+	{- Let the DirWatcher thread run until signalled to pause it,
+	 - then wait for a resume signal, and restart. -}
+	waitFor PauseWatcher $ do
+		liftIO $ stopWatchDir handle
+		waitFor ResumeWatcher runWatcher
+  where
+	hook a = Just <$> asIO2 (runHandler a)
+
+waitFor :: WatcherControl -> Assistant () -> Assistant ()
+waitFor sig next = do
+	r <- liftIO (E.try pause :: IO (Either E.SomeException ()))
+	case r of
+		Left e -> case E.fromException e of
+			Just s
+				| s == sig -> next
+			_ -> noop
+		_ -> noop
+  where
+	pause = runEvery (Seconds 86400) noop
+
+{- Initial scartup scan. The action should return once the scan is complete. -}
+startupScan :: IO a -> Assistant a
+startupScan scanner = do
+	liftAnnex $ showAction "scanning"
+	alertWhile' startupScanAlert $ do
+		r <- liftIO scanner
+
+		-- Notice any files that were deleted before
+		-- watching was started.
+		top <- liftAnnex $ fromRepo Git.repoPath
+		(fs, cleanup) <- liftAnnex $ inRepo $ LsFiles.deleted [top]
+		forM_ fs $ \f -> do
+			liftAnnex $ onDel' f
+			maybe noop recordChange =<< madeChange f RmChange
+		void $ liftIO cleanup
+		
+		liftAnnex $ showAction "started"
+		liftIO $ putStrLn ""
+		
+		modifyDaemonStatus_ $ \s -> s { scanComplete = True }
+
+		-- Ensure that the Committer sees any changes
+		-- that it did not process, and acts on them now that
+		-- the scan is complete.
+		refillChanges =<< getAnyChanges
+
+		return (True, r)
+
+{- Hardcoded ignores, passed to the DirWatcher so it can avoid looking
+ - at the entire .git directory. Does not include .gitignores. -}
+ignored :: FilePath -> Bool
+ignored = ig . takeFileName
+  where
+	ig ".git" = True
+	ig ".gitignore" = True
+	ig ".gitattributes" = True
+#ifdef darwin_HOST_OS
+	ig ".DS_Store" = True
+#endif
+	ig _ = False
+
+unlessIgnored :: FilePath -> Assistant (Maybe Change) -> Assistant (Maybe Change)
+unlessIgnored file a = ifM (liftAnnex $ checkIgnored file)
+	( noChange
+	, a
+	)
+
+type Handler = FilePath -> Maybe FileStatus -> Assistant (Maybe Change)
+
+{- Runs an action handler, and if there was a change, adds it to the ChangeChan.
+ -
+ - Exceptions are ignored, otherwise a whole watcher thread could be crashed.
+ -}
+runHandler :: Handler -> FilePath -> Maybe FileStatus -> Assistant ()
+runHandler handler file filestatus = void $ do
+	r <- tryIO <~> handler (normalize file) filestatus
+	case r of
+		Left e -> liftIO $ print e
+		Right Nothing -> noop
+		Right (Just change) -> do
+			-- Just in case the commit thread is not
+			-- flushing the queue fast enough.
+			liftAnnex Annex.Queue.flushWhenFull
+			recordChange change
+  where
+  	normalize f
+		| "./" `isPrefixOf` file = drop 2 f
+		| otherwise = f
+
+{- Small files are added to git as-is, while large ones go into the annex. -}
+add :: FileMatcher Annex -> FilePath -> Assistant (Maybe Change)
+add bigfilematcher file = ifM (liftAnnex $ checkFileMatcher bigfilematcher file)
+	( pendingAddChange file
+	, do
+		liftAnnex $ Annex.Queue.addCommand "add"
+			[Params "--force --"] [file]
+		madeChange file AddFileChange
+	)
+
+onAdd :: FileMatcher Annex -> Handler
+onAdd matcher file filestatus
+	| maybe False isRegularFile filestatus =
+		unlessIgnored file $
+			add matcher file
+	| otherwise = noChange
+
+shouldRestage :: DaemonStatus -> Bool
+shouldRestage ds = scanComplete ds || forceRestage ds
+
+{- In direct mode, add events are received for both new files, and
+ - modified existing files.
+ -}
+onAddDirect :: Bool -> FileMatcher Annex -> Handler
+onAddDirect symlinkssupported matcher file fs = do
+	v <- liftAnnex $ catKeyFile file
+	case (v, fs) of
+		(Just key, Just filestatus) ->
+			ifM (liftAnnex $ sameFileStatus key filestatus)
+				{- It's possible to get an add event for
+				 - an existing file that is not
+				 - really modified, but it might have
+				 - just been deleted and been put back,
+				 - so it symlink is restaged to make sure. -}
+				( ifM (shouldRestage <$> getDaemonStatus)
+					( do
+						link <- liftAnnex $ inRepo $ gitAnnexLink file key
+						addLink file link (Just key)
+					, noChange
+					)
+				, guardSymlinkStandin (Just key) $ do
+					debug ["changed direct", file]
+					liftAnnex $ changedDirect key file
+					add matcher file
+				)
+		_ -> unlessIgnored file $
+			guardSymlinkStandin Nothing $ do
+				debug ["add direct", file]
+				add matcher file
+  where
+ 	{- On a filesystem without symlinks, we'll get changes for regular
+	 - files that git uses to stand-in for symlinks. Detect when
+	 - this happens, and stage the symlink, rather than annexing the
+	 - file. -}
+	guardSymlinkStandin mk a
+		| symlinkssupported = a
+		| otherwise = do
+			linktarget <- liftAnnex $ getAnnexLinkTarget file
+			case linktarget of
+				Nothing -> a
+				Just lt -> do
+					case fileKey $ takeFileName lt of
+						Nothing -> noop
+						Just key -> void $ liftAnnex $
+							addAssociatedFile key file
+					onAddSymlink' linktarget mk True file fs
+
+{- A symlink might be an arbitrary symlink, which is just added.
+ - Or, if it is a git-annex symlink, ensure it points to the content
+ - before adding it.
+ -}
+onAddSymlink :: Bool -> Handler
+onAddSymlink isdirect file filestatus = unlessIgnored file $ do
+	linktarget <- liftIO (catchMaybeIO $ readSymbolicLink file)
+	kv <- liftAnnex (Backend.lookupFile file)
+	onAddSymlink' linktarget (fmap fst kv) isdirect file filestatus
+
+onAddSymlink' :: Maybe String -> Maybe Key -> Bool -> Handler
+onAddSymlink' linktarget mk isdirect file filestatus = go mk
+  where
+  	go (Just key) = do
+		when isdirect $
+			liftAnnex $ void $ addAssociatedFile key file
+		link <- liftAnnex $ inRepo $ gitAnnexLink file key
+		if linktarget == Just link
+			then ensurestaged (Just link) =<< getDaemonStatus
+			else do
+				unless isdirect $
+					liftAnnex $ replaceFile file $
+						makeAnnexLink link
+				addLink file link (Just key)
+	-- other symlink, not git-annex
+	go Nothing = ensurestaged linktarget =<< getDaemonStatus
+
+	{- This is often called on symlinks that are already
+	 - staged correctly. A symlink may have been deleted
+	 - and being re-added, or added when the watcher was
+	 - not running. So they're normally restaged to make sure.
+	 -
+	 - As an optimisation, during the startup scan, avoid
+	 - restaging everything. Only links that were created since
+	 - the last time the daemon was running are staged.
+	 - (If the daemon has never ran before, avoid staging
+	 - links too.)
+	 -}
+	ensurestaged (Just link) daemonstatus
+		| shouldRestage daemonstatus = addLink file link mk
+		| otherwise = case filestatus of
+			Just s
+				| not (afterLastDaemonRun (statusChangeTime s) daemonstatus) -> noChange
+			_ -> addLink file link mk
+	ensurestaged Nothing _ = noChange
+
+{- For speed, tries to reuse the existing blob for symlink target. -}
+addLink :: FilePath -> FilePath -> Maybe Key -> Assistant (Maybe Change)
+addLink file link mk = do
+	debug ["add symlink", file]
+	liftAnnex $ do
+		v <- catObjectDetails $ Ref $ ':':file
+		case v of
+			Just (currlink, sha, _type)
+				| s2w8 link == L.unpack currlink ->
+					stageSymlink file sha
+			_ -> stageSymlink file =<< hashSymlink link
+	madeChange file $ LinkChange mk
+
+onDel :: Handler
+onDel file _ = do
+	debug ["file deleted", file]
+	liftAnnex $ onDel' file
+	madeChange file RmChange
+
+onDel' :: FilePath -> Annex ()
+onDel' file = do
+	whenM isDirect $ do
+		mkey <- catKeyFile file
+		case mkey of
+			Nothing -> noop
+			Just key -> void $ removeAssociatedFile key file
+	Annex.Queue.addUpdateIndex =<<
+		inRepo (Git.UpdateIndex.unstageFile file)
+
+{- A directory has been deleted, or moved, so tell git to remove anything
+ - that was inside it from its cache. Since it could reappear at any time,
+ - use --cached to only delete it from the index.
+ -
+ - This queues up a lot of RmChanges, which assists the Committer in
+ - pairing up renamed files when the directory was renamed. -}
+onDelDir :: Handler
+onDelDir dir _ = do
+	debug ["directory deleted", dir]
+	(fs, clean) <- liftAnnex $ inRepo $ LsFiles.deleted [dir]
+
+	liftAnnex $ mapM_ onDel' fs
+
+	-- Get the events queued up as fast as possible, so the
+	-- committer sees them all in one block.
+	now <- liftIO getCurrentTime
+	recordChanges $ map (\f -> Change now f RmChange) fs
+
+	void $ liftIO clean
+	liftAnnex Annex.Queue.flushWhenFull
+	noChange
+
+{- Called when there's an error with inotify or kqueue. -}
+onErr :: Handler
+onErr msg _ = do
+	liftAnnex $ warning msg
+	void $ addAlert $ warningAlert "watcher" msg
+	noChange

Assistant/Threads/WebApp.hs

@@ -0,0 +1,137 @@
+{- git-annex assistant webapp thread
+ -
+ - Copyright 2012-2014 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE TemplateHaskell, MultiParamTypeClasses #-}
+{-# LANGUAGE CPP #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Assistant.Threads.WebApp where
+
+import Assistant.Common
+import Assistant.WebApp
+import Assistant.WebApp.Types
+import Assistant.WebApp.DashBoard
+import Assistant.WebApp.SideBar
+import Assistant.WebApp.Notifications
+import Assistant.WebApp.RepoList
+import Assistant.WebApp.Configurators
+import Assistant.WebApp.Configurators.Local
+import Assistant.WebApp.Configurators.Ssh
+import Assistant.WebApp.Configurators.Pairing
+import Assistant.WebApp.Configurators.AWS
+import Assistant.WebApp.Configurators.IA
+import Assistant.WebApp.Configurators.WebDAV
+import Assistant.WebApp.Configurators.XMPP
+import Assistant.WebApp.Configurators.Preferences
+import Assistant.WebApp.Configurators.Unused
+import Assistant.WebApp.Configurators.Edit
+import Assistant.WebApp.Configurators.Delete
+import Assistant.WebApp.Configurators.Fsck
+import Assistant.WebApp.Configurators.Upgrade
+import Assistant.WebApp.Documentation
+import Assistant.WebApp.Control
+import Assistant.WebApp.OtherRepos
+import Assistant.WebApp.Repair
+import Assistant.Types.ThreadedMonad
+import Utility.WebApp
+import Utility.Tmp
+import Utility.FileMode
+import Git
+import qualified Annex
+
+import Yesod
+import Network.Socket (SockAddr, HostName)
+import Data.Text (pack, unpack)
+import qualified Network.Wai.Handler.WarpTLS as TLS
+
+mkYesodDispatch "WebApp" $(parseRoutesFile "Assistant/WebApp/routes")
+
+type Url = String
+
+webAppThread
+	:: AssistantData
+	-> UrlRenderer
+	-> Bool
+	-> Maybe String
+	-> Maybe (IO Url)
+	-> Maybe HostName
+	-> Maybe (Url -> FilePath -> IO ())
+	-> NamedThread
+webAppThread assistantdata urlrenderer noannex cannotrun postfirstrun listenhost onstartup = thread $ liftIO $ do
+	listenhost' <- if isJust listenhost
+		then pure listenhost
+		else getAnnex $ annexListen <$> Annex.getGitConfig
+	tlssettings <- getAnnex getTlsSettings
+#ifdef __ANDROID__
+	when (isJust listenhost') $
+		-- See Utility.WebApp
+		error "Sorry, --listen is not currently supported on Android"
+#endif
+	webapp <- WebApp
+		<$> pure assistantdata
+		<*> genAuthToken
+		<*> getreldir
+		<*> pure staticRoutes
+		<*> pure postfirstrun
+		<*> pure cannotrun
+		<*> pure noannex
+		<*> pure listenhost'
+	setUrlRenderer urlrenderer $ yesodRender webapp (pack "")
+	app <- toWaiAppPlain webapp
+	app' <- ifM debugEnabled
+		( return $ httpDebugLogger app
+		, return app
+		)
+	runWebApp tlssettings listenhost' app' $ \addr -> if noannex
+		then withTmpFile "webapp.html" $ \tmpfile h -> do
+			hClose h
+			go tlssettings addr webapp tmpfile Nothing
+		else do
+			htmlshim <- getAnnex' $ fromRepo gitAnnexHtmlShim
+			urlfile <- getAnnex' $ fromRepo gitAnnexUrlFile
+			go tlssettings addr webapp htmlshim (Just urlfile)
+  where
+  	-- The webapp thread does not wait for the startupSanityCheckThread
+	-- to finish, so that the user interface remains responsive while
+	-- that's going on.
+	thread = namedThreadUnchecked "WebApp"
+	getreldir
+		| noannex = return Nothing
+		| otherwise = Just <$>
+			(relHome =<< absPath
+				=<< getAnnex' (fromRepo repoPath))
+	go tlssettings addr webapp htmlshim urlfile = do
+		let url = myUrl tlssettings webapp addr
+		maybe noop (`writeFileProtected` url) urlfile
+		writeHtmlShim "Starting webapp..." url htmlshim
+		maybe noop (\a -> a url htmlshim) onstartup
+
+	getAnnex a
+		| noannex = pure Nothing
+		| otherwise = getAnnex' a
+	getAnnex' = runThreadState (threadState assistantdata)
+
+myUrl :: Maybe TLS.TLSSettings -> WebApp -> SockAddr -> Url
+myUrl tlssettings webapp addr = unpack $ yesodRender webapp urlbase DashboardR []
+  where
+	urlbase = pack $ proto ++ "://" ++ show addr
+	proto
+		| isJust tlssettings = "https"
+		| otherwise = "http"
+
+getTlsSettings :: Annex (Maybe TLS.TLSSettings)
+getTlsSettings = do
+#ifdef WITH_WEBAPP_SECURE
+	cert <- fromRepo gitAnnexWebCertificate
+	privkey <- fromRepo gitAnnexWebPrivKey
+	ifM (liftIO $ allM doesFileExist [cert, privkey])
+		( return $ Just $ TLS.tlsSettings cert privkey
+		, return Nothing
+		)
+#else
+	return Nothing
+#endif

Assistant/Threads/XMPPClient.hs

@@ -0,0 +1,368 @@
+{- git-annex XMPP client
+ -
+ - Copyright 2012, 2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Assistant.Threads.XMPPClient where
+
+import Assistant.Common
+import Assistant.XMPP
+import Assistant.XMPP.Client
+import Assistant.NetMessager
+import Assistant.Types.NetMessager
+import Assistant.Types.Buddies
+import Assistant.XMPP.Buddies
+import Assistant.Sync
+import Assistant.DaemonStatus
+import qualified Remote
+import Utility.ThreadScheduler
+import Assistant.WebApp (UrlRenderer)
+import Assistant.WebApp.Types hiding (liftAssistant)
+import Assistant.Alert
+import Assistant.Pairing
+import Assistant.XMPP.Git
+import Annex.UUID
+import Logs.UUID
+
+import Network.Protocol.XMPP
+import Control.Concurrent
+import Control.Concurrent.STM.TMVar
+import Control.Concurrent.STM (atomically)
+import qualified Data.Text as T
+import qualified Data.Set as S
+import qualified Data.Map as M
+import qualified Git.Branch
+import Data.Time.Clock
+import Control.Concurrent.Async
+
+xmppClientThread :: UrlRenderer -> NamedThread
+xmppClientThread urlrenderer = namedThread "XMPPClient" $
+	restartableClient . xmppClient urlrenderer =<< getAssistant id
+
+{- Runs the client, handing restart events. -}
+restartableClient :: (XMPPCreds -> IO ()) -> Assistant ()
+restartableClient a = forever $ go =<< liftAnnex getXMPPCreds
+  where
+	go Nothing = waitNetMessagerRestart
+	go (Just creds) = do
+		tid <- liftIO $ forkIO $ a creds
+		waitNetMessagerRestart
+		liftIO $ killThread tid
+
+xmppClient :: UrlRenderer -> AssistantData -> XMPPCreds -> IO ()
+xmppClient urlrenderer d creds =
+	retry (runclient creds) =<< getCurrentTime
+  where
+	liftAssistant = runAssistant d
+	inAssistant = liftIO . liftAssistant
+
+	{- When the client exits, it's restarted;
+	 - if it keeps failing, back off to wait 5 minutes before
+	 - trying it again. -}
+	retry client starttime = do
+		{- The buddy list starts empty each time
+		 - the client connects, so that stale info
+		 - is not retained. -}
+		liftAssistant $
+			updateBuddyList (const noBuddies) <<~ buddyList
+		void client
+		liftAssistant $ modifyDaemonStatus_ $ \s -> s
+			{ xmppClientID = Nothing }
+		now <- getCurrentTime
+		if diffUTCTime now starttime > 300
+			then do
+				liftAssistant $ debug ["connection lost; reconnecting"]
+				retry client now
+			else do
+				liftAssistant $ debug ["connection failed; will retry"]
+				threadDelaySeconds (Seconds 300)
+				retry client =<< getCurrentTime
+
+	runclient c = liftIO $ connectXMPP c $ \jid -> do
+		selfjid <- bindJID jid
+		putStanza gitAnnexSignature
+
+		inAssistant $ do
+			modifyDaemonStatus_ $ \s -> s
+				{ xmppClientID = Just $ xmppJID creds }
+			debug ["connected", logJid selfjid]
+
+		lasttraffic <- liftIO $ atomically . newTMVar =<< getCurrentTime
+
+		sender <- xmppSession $ sendnotifications selfjid
+		receiver <- xmppSession $ receivenotifications selfjid lasttraffic
+		pinger <- xmppSession $ sendpings selfjid lasttraffic
+		{- Run all 3 threads concurrently, until
+		 - any of them throw an exception.
+		 - Then kill all 3 threads, and rethrow the
+		 - exception.
+		 -
+		 - If this thread gets an exception, the 3 threads
+		 - will also be killed. -}
+		liftIO $ pinger `concurrently` sender `concurrently` receiver
+
+	sendnotifications selfjid = forever $
+		join $ inAssistant $ relayNetMessage selfjid
+	receivenotifications selfjid lasttraffic = forever $ do
+		l <- decodeStanza selfjid <$> getStanza
+		void $ liftIO $ atomically . swapTMVar lasttraffic =<< getCurrentTime
+		inAssistant $ debug
+			["received:", show $ map logXMPPEvent l]
+		mapM_ (handle selfjid) l
+	sendpings selfjid lasttraffic = forever $ do
+		putStanza pingstanza
+
+		startping <- liftIO getCurrentTime
+		liftIO $ threadDelaySeconds (Seconds 120)
+		t <- liftIO $ atomically $ readTMVar lasttraffic
+		when (t < startping) $ do
+			inAssistant $ debug ["ping timeout"]
+			error "ping timeout"
+	  where
+		{- XEP-0199 says that the server will respond with either
+		 - a ping response or an error message. Either will
+		 - cause traffic, so good enough. -}
+	  	pingstanza = xmppPing selfjid
+
+	handle selfjid (PresenceMessage p) = do
+		void $ inAssistant $ 
+			updateBuddyList (updateBuddies p) <<~ buddyList
+		resendImportantMessages selfjid p
+	handle _ (GotNetMessage QueryPresence) = putStanza gitAnnexSignature
+	handle _ (GotNetMessage (NotifyPush us)) = void $ inAssistant $ pull us
+	handle selfjid (GotNetMessage (PairingNotification stage c u)) =
+		maybe noop (inAssistant . pairMsgReceived urlrenderer stage u selfjid) (parseJID c)
+	handle _ (GotNetMessage m@(Pushing _ pushstage))
+		| isPushNotice pushstage = inAssistant $ handlePushNotice m
+		| isPushInitiation pushstage = inAssistant $ queuePushInitiation m
+		| otherwise = inAssistant $ storeInbox m
+	handle _ (Ignorable _) = noop
+	handle _ (Unknown _) = noop
+	handle _ (ProtocolError _) = noop
+
+	resendImportantMessages selfjid (Presence { presenceFrom = Just jid }) = do
+		let c = formatJID jid
+		(stored, sent) <- inAssistant $
+			checkImportantNetMessages (formatJID (baseJID jid), c)
+		forM_ (S.toList $ S.difference stored sent) $ \msg -> do
+			let msg' = readdressNetMessage msg c
+			inAssistant $ debug
+				[ "sending to new client:"
+				, logJid jid
+				, show $ logNetMessage msg'
+				]
+			join $ inAssistant $ convertNetMsg msg' selfjid
+			inAssistant $ sentImportantNetMessage msg c
+	resendImportantMessages _ _ = noop
+
+data XMPPEvent
+	= GotNetMessage NetMessage
+	| PresenceMessage Presence
+	| Ignorable ReceivedStanza
+	| Unknown ReceivedStanza
+	| ProtocolError ReceivedStanza
+	deriving Show
+
+logXMPPEvent :: XMPPEvent -> String
+logXMPPEvent (GotNetMessage m) = logNetMessage m
+logXMPPEvent (PresenceMessage p) = logPresence p
+logXMPPEvent (Ignorable (ReceivedPresence p)) = "Ignorable " ++ logPresence p
+logXMPPEvent (Ignorable _) = "Ignorable message"
+logXMPPEvent (Unknown _) = "Unknown message"
+logXMPPEvent (ProtocolError _) = "Protocol error message"
+
+logPresence :: Presence -> String
+logPresence (p@Presence { presenceFrom = Just jid }) = unwords
+	[ "Presence from"
+	, logJid jid
+	, show $ extractGitAnnexTag p
+	]
+logPresence _ = "Presence from unknown"
+
+logJid :: JID -> String
+logJid jid =
+	let name = T.unpack (buddyName jid)
+	    resource = maybe "" (T.unpack . strResource) (jidResource jid)
+	in take 1 name ++ show (length name) ++ "/" ++ resource
+
+logClient :: Client -> String
+logClient (Client jid) = logJid jid
+
+{- Decodes an XMPP stanza into one or more events. -}
+decodeStanza :: JID -> ReceivedStanza -> [XMPPEvent]
+decodeStanza selfjid s@(ReceivedPresence p)
+	| presenceType p == PresenceError = [ProtocolError s]
+	| isNothing (presenceFrom p) = [Ignorable s]
+	| presenceFrom p == Just selfjid = [Ignorable s]
+	| otherwise = maybe [PresenceMessage p] decode (gitAnnexTagInfo p)
+  where
+	decode i
+		| tagAttr i == pushAttr = impliedp $ GotNetMessage $ NotifyPush $
+			decodePushNotification (tagValue i)
+		| tagAttr i == queryAttr = impliedp $ GotNetMessage QueryPresence
+		| otherwise = [Unknown s]
+	{- Things sent via presence imply a presence message,
+	 - along with their real meaning. -}
+	impliedp v = [PresenceMessage p, v]
+decodeStanza selfjid s@(ReceivedMessage m)
+	| isNothing (messageFrom m) = [Ignorable s]
+	| messageFrom m == Just selfjid = [Ignorable s]
+	| messageType m == MessageError = [ProtocolError s]
+	| otherwise = [fromMaybe (Unknown s) (GotNetMessage <$> decodeMessage m)]
+decodeStanza _ s = [Unknown s]
+
+{- Waits for a NetMessager message to be sent, and relays it to XMPP.
+ -
+ - Chat messages must be directed to specific clients, not a base
+ - account JID, due to git-annex clients using a negative presence priority.
+ - PairingNotification messages are always directed at specific
+ - clients, but Pushing messages are sometimes not, and need to be exploded
+ - out to specific clients.
+ -
+ - Important messages, not directed at any specific client, 
+ - are cached to be sent later when additional clients connect.
+ -}
+relayNetMessage :: JID -> Assistant (XMPP ())
+relayNetMessage selfjid = do
+	msg <- waitNetMessage
+	debug ["sending:", logNetMessage msg]
+	a1 <- handleImportant msg
+	a2 <- convert msg
+	return (a1 >> a2)
+  where
+	handleImportant msg = case parseJID =<< isImportantNetMessage msg of
+		Just tojid
+			| tojid == baseJID tojid -> do
+				storeImportantNetMessage msg (formatJID tojid) $
+					\c -> (baseJID <$> parseJID c) == Just tojid
+				return $ putStanza presenceQuery
+		_ -> return noop
+	convert (Pushing c pushstage) = withOtherClient selfjid c $ \tojid ->
+		if tojid == baseJID tojid
+			then do
+				clients <- maybe [] (S.toList . buddyAssistants)
+					<$> getBuddy (genBuddyKey tojid) <<~ buddyList
+				debug ["exploded undirected message to clients", unwords $ map logClient clients]
+				return $ forM_ clients $ \(Client jid) ->
+					putStanza $ pushMessage pushstage jid selfjid
+			else do
+				debug ["to client:", logJid tojid]
+				return $ putStanza $ pushMessage pushstage tojid selfjid
+	convert msg = convertNetMsg msg selfjid
+
+{- Converts a NetMessage to an XMPP action. -}
+convertNetMsg :: NetMessage -> JID -> Assistant (XMPP ())
+convertNetMsg msg selfjid = convert msg
+  where
+	convert (NotifyPush us) = return $ putStanza $ pushNotification us
+	convert QueryPresence = return $ putStanza presenceQuery
+	convert (PairingNotification stage c u) = withOtherClient selfjid c $ \tojid -> do
+		changeBuddyPairing tojid True
+		return $ putStanza $ pairingNotification stage u tojid selfjid
+	convert (Pushing c pushstage) = withOtherClient selfjid c $ \tojid ->
+		return $ putStanza $  pushMessage pushstage tojid selfjid
+
+withOtherClient :: JID -> ClientID -> (JID -> Assistant (XMPP ())) -> Assistant (XMPP ())
+withOtherClient selfjid c a = case parseJID c of
+	Nothing -> return noop
+	Just tojid
+		| tojid == selfjid -> return noop
+		| otherwise -> a tojid
+
+withClient :: ClientID -> (JID -> XMPP ()) -> XMPP ()
+withClient c a = maybe noop a $ parseJID c
+
+{- Returns an IO action that runs a XMPP action in a separate thread,
+ - using a session to allow it to access the same XMPP client. -}
+xmppSession :: XMPP () -> XMPP (IO ())
+xmppSession a = do
+	s <- getSession
+	return $ void $ runXMPP s a
+
+{- We only pull from one remote out of the set listed in the push
+ - notification, as an optimisation.
+ -
+ - Note that it might be possible (though very unlikely) for the push
+ - notification to take a while to be sent, and multiple pushes happen
+ - before it is sent, so it includes multiple remotes that were pushed
+ - to at different times. 
+ -
+ - It could then be the case that the remote we choose had the earlier
+ - push sent to it, but then failed to get the later push, and so is not
+ - fully up-to-date. If that happens, the pushRetryThread will come along
+ - and retry the push, and we'll get another notification once it succeeds,
+ - and pull again. -}
+pull :: [UUID] -> Assistant ()
+pull [] = noop
+pull us = do
+	rs <- filter matching . syncGitRemotes <$> getDaemonStatus
+	debug $ "push notification for" : map (fromUUID . Remote.uuid ) rs
+	pullone rs =<< liftAnnex (inRepo Git.Branch.current)
+  where
+	matching r = Remote.uuid r `S.member` s
+	s = S.fromList us
+
+	pullone [] _ = noop
+	pullone (r:rs) branch =
+		unlessM (null . fst <$> manualPull branch [r]) $
+			pullone rs branch
+
+{- PairReq from another client using our JID is automatically
+ - accepted. This is so pairing devices all using the same XMPP
+ - account works without confirmations.
+ -
+ - Also, autoaccept PairReq from the same JID of any repo we've
+ - already paired with, as long as the UUID in the PairReq is
+ - one we know about.
+-}
+pairMsgReceived :: UrlRenderer -> PairStage -> UUID -> JID -> JID -> Assistant ()
+pairMsgReceived urlrenderer PairReq theiruuid selfjid theirjid
+	| baseJID selfjid == baseJID theirjid = autoaccept
+	| otherwise = do
+		knownjids <- mapMaybe (parseJID . getXMPPClientID)
+			. filter Remote.isXMPPRemote . syncRemotes <$> getDaemonStatus
+		um <- liftAnnex uuidMap
+		if elem (baseJID theirjid) knownjids && M.member theiruuid um
+			then autoaccept
+			else showalert
+
+  where
+	autoaccept = do
+		selfuuid <- liftAnnex getUUID
+		sendNetMessage $
+			PairingNotification PairAck (formatJID theirjid) selfuuid
+		finishXMPPPairing theirjid theiruuid
+	-- Show an alert to let the user decide if they want to pair.
+	showalert = do
+		button <- mkAlertButton True (T.pack "Respond") urlrenderer $
+			ConfirmXMPPPairFriendR $
+				PairKey theiruuid $ formatJID theirjid
+		void $ addAlert $ pairRequestReceivedAlert
+			(T.unpack $ buddyName theirjid)
+			button
+
+{- PairAck must come from one of the buddies we are pairing with;
+ - don't pair with just anyone. -}
+pairMsgReceived _ PairAck theiruuid _selfjid theirjid =
+	whenM (isBuddyPairing theirjid) $ do
+		changeBuddyPairing theirjid False
+		selfuuid <- liftAnnex getUUID
+		sendNetMessage $
+			PairingNotification PairDone (formatJID theirjid) selfuuid
+		finishXMPPPairing theirjid theiruuid
+
+pairMsgReceived _ PairDone _theiruuid _selfjid theirjid =
+	changeBuddyPairing theirjid False
+
+isBuddyPairing :: JID -> Assistant Bool
+isBuddyPairing jid = maybe False buddyPairing <$> 
+	getBuddy (genBuddyKey jid) <<~ buddyList
+
+changeBuddyPairing :: JID -> Bool -> Assistant ()
+changeBuddyPairing jid ispairing =
+	updateBuddyList (M.adjust set key) <<~ buddyList
+  where
+	key = genBuddyKey jid
+	set b = b { buddyPairing = ispairing }

Assistant/Threads/XMPPPusher.hs

@@ -0,0 +1,81 @@
+{- git-annex XMPP pusher threads
+ -
+ - This is a pair of threads. One handles git send-pack,
+ - and the other git receive-pack. Each thread can be running at most
+ - one such operation at a time.
+ -
+ - Why not use a single thread? Consider two clients A and B.
+ - If both decide to run a receive-pack at the same time to the other,
+ - they would deadlock with only one thread. For larger numbers of
+ - clients, the two threads are also sufficient.
+ -
+ - Copyright 2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Assistant.Threads.XMPPPusher where
+
+import Assistant.Common
+import Assistant.NetMessager
+import Assistant.Types.NetMessager
+import Assistant.WebApp (UrlRenderer)
+import Assistant.WebApp.Configurators.XMPP (checkCloudRepos)
+import Assistant.XMPP.Git
+
+import Control.Exception as E
+
+xmppSendPackThread :: UrlRenderer -> NamedThread
+xmppSendPackThread = pusherThread "XMPPSendPack" SendPack
+
+xmppReceivePackThread :: UrlRenderer -> NamedThread
+xmppReceivePackThread = pusherThread "XMPPReceivePack" ReceivePack
+
+pusherThread :: String -> PushSide -> UrlRenderer -> NamedThread
+pusherThread threadname side urlrenderer = namedThread threadname $ go Nothing
+  where
+  	go lastpushedto = do
+		msg <- waitPushInitiation side $ selectNextPush lastpushedto
+		debug ["started running push", logNetMessage msg]
+
+		runpush <- asIO $ runPush checker msg
+		r <- liftIO (E.try runpush :: IO (Either SomeException (Maybe ClientID)))
+		let successful = case r of
+			Right (Just _) -> True
+			_ -> False
+
+		{- Empty the inbox, because stuff may have
+		 - been left in it if the push failed. -}
+		let justpushedto = getclient msg
+		maybe noop (`emptyInbox` side) justpushedto
+
+		debug ["finished running push", logNetMessage msg, show successful]
+		go $ if successful then justpushedto else lastpushedto
+	
+	checker = checkCloudRepos urlrenderer
+
+	getclient (Pushing cid _) = Just cid
+	getclient _ = Nothing
+
+{- Select the next push to run from the queue.
+ - The queue cannot be empty!
+ -
+ - We prefer to select the most recently added push, because its requestor
+ - is more likely to still be connected.
+ -
+ - When passed the ID of a client we just pushed to, we prefer to not
+ - immediately push again to that same client. This avoids one client 
+ - drowing out others. So pushes from the client we just pushed to are 
+ - relocated to the beginning of the list, to be processed later.
+ -}
+selectNextPush :: Maybe ClientID -> [NetMessage] -> (NetMessage, [NetMessage])
+selectNextPush _ (m:[]) = (m, []) -- common case
+selectNextPush _ [] = error "selectNextPush: empty list"
+selectNextPush lastpushedto l = go [] l
+  where
+	go (r:ejected) [] = (r, ejected)
+	go rejected (m:ms) = case m of
+		(Pushing clientid _)
+			| Just clientid /= lastpushedto -> (m, rejected ++ ms)
+		_ -> go (m:rejected) ms
+  	go [] [] = undefined

Assistant/TransferQueue.hs

@@ -0,0 +1,233 @@
+{- git-annex assistant pending transfer queue
+ -
+ - Copyright 2012-2014 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE BangPatterns #-}
+
+module Assistant.TransferQueue (
+	TransferQueue,
+	Schedule(..),
+	newTransferQueue,
+	getTransferQueue,
+	queueTransfers,
+	queueTransfersMatching,
+	queueDeferredDownloads,
+	queueTransfer,
+	queueTransferAt,
+	queueTransferWhenSmall,
+	getNextTransfer,
+	getMatchingTransfers,
+	dequeueTransfers,
+) where
+
+import Assistant.Common
+import Assistant.DaemonStatus
+import Assistant.Types.TransferQueue
+import Logs.Transfer
+import Types.Remote
+import qualified Remote
+import qualified Types.Remote as Remote
+import Annex.Wanted
+import Utility.TList
+
+import Control.Concurrent.STM
+import qualified Data.Map as M
+import qualified Data.Set as S
+
+type Reason = String
+
+{- Reads the queue's content without blocking or changing it. -}
+getTransferQueue :: Assistant [(Transfer, TransferInfo)]
+getTransferQueue = (atomically . readTList . queuelist) <<~ transferQueue
+
+stubInfo :: AssociatedFile -> Remote -> TransferInfo
+stubInfo f r = stubTransferInfo
+	{ transferRemote = Just r
+	, associatedFile = f
+	}
+
+{- Adds transfers to queue for some of the known remotes.
+ - Honors preferred content settings, only transferring wanted files. -}
+queueTransfers :: Reason -> Schedule -> Key -> AssociatedFile -> Direction -> Assistant Bool
+queueTransfers = queueTransfersMatching (const True)
+
+{- Adds transfers to queue for some of the known remotes, that match a
+ - condition. Honors preferred content settings. -}
+queueTransfersMatching :: (UUID -> Bool) -> Reason -> Schedule -> Key -> AssociatedFile -> Direction -> Assistant Bool
+queueTransfersMatching matching reason schedule k f direction
+	| direction == Download = ifM (liftAnnex $ wantGet True (Just k) f)
+		( go
+		, return False
+		)
+	| otherwise = go
+  where
+	go = do
+		
+		rs <- liftAnnex . selectremotes
+			=<< syncDataRemotes <$> getDaemonStatus
+		let matchingrs = filter (matching . Remote.uuid) rs
+		if null matchingrs
+			then do
+				defer
+				return False
+			else do
+				forM_ matchingrs $ \r ->
+					enqueue reason schedule (gentransfer r) (stubInfo f r)
+				return True
+	selectremotes rs
+		{- Queue downloads from all remotes that
+		 - have the key. The list of remotes is ordered with
+		 - cheapest first. More expensive ones will only be tried
+		 - if downloading from a cheap one fails. -}
+		| direction == Download = do
+			s <- locs
+			return $ filter (inset s) rs
+		{- Upload to all remotes that want the content and don't
+		 - already have it. -}
+		| otherwise = do
+			s <- locs
+			filterM (wantSend True (Just k) f . Remote.uuid) $
+				filter (\r -> not (inset s r || Remote.readonly r)) rs
+	  where
+	  	locs = S.fromList <$> Remote.keyLocations k
+		inset s r = S.member (Remote.uuid r) s
+	gentransfer r = Transfer
+		{ transferDirection = direction
+		, transferKey = k
+		, transferUUID = Remote.uuid r
+		}
+	defer
+		{- Defer this download, as no known remote has the key. -}
+		| direction == Download = do
+			q <- getAssistant transferQueue
+			void $ liftIO $ atomically $
+				consTList (deferreddownloads q) (k, f)
+		| otherwise = noop
+
+{- Queues any deferred downloads that can now be accomplished, leaving
+ - any others in the list to try again later. -}
+queueDeferredDownloads :: Reason -> Schedule -> Assistant ()
+queueDeferredDownloads reason schedule = do
+	q <- getAssistant transferQueue
+	l <- liftIO $ atomically $ readTList (deferreddownloads q)
+	rs <- syncDataRemotes <$> getDaemonStatus
+	left <- filterM (queue rs) l
+	unless (null left) $
+		liftIO $ atomically $ appendTList (deferreddownloads q) left
+  where
+	queue rs (k, f) = do
+		uuids <- liftAnnex $ Remote.keyLocations k
+		let sources = filter (\r -> uuid r `elem` uuids) rs
+		unless (null sources) $
+			forM_ sources $ \r ->
+				enqueue reason schedule 
+					(gentransfer r) (stubInfo f r)
+		return $ null sources
+	  where
+		gentransfer r = Transfer
+			{ transferDirection = Download
+			, transferKey = k
+			, transferUUID = Remote.uuid r
+			}
+
+enqueue :: Reason -> Schedule -> Transfer -> TransferInfo -> Assistant ()
+enqueue reason schedule t info
+	| schedule == Next = go consTList
+	| otherwise = go snocTList
+  where
+	go modlist = whenM (add modlist) $ do
+		debug [ "queued", describeTransfer t info, ": " ++ reason ]
+		notifyTransfer
+	add modlist = do
+		q <- getAssistant transferQueue
+		dstatus <- getAssistant daemonStatusHandle
+		liftIO $ atomically $ ifM (checkRunningTransferSTM dstatus t)
+			( return False
+			, do
+				l <- readTList (queuelist q)
+				if (t `notElem` map fst l)
+					then do	
+						void $ modifyTVar' (queuesize q) succ
+						void $ modlist (queuelist q) (t, info)
+						return True
+					else return False
+			)
+
+{- Adds a transfer to the queue. -}
+queueTransfer :: Reason -> Schedule -> AssociatedFile -> Transfer -> Remote -> Assistant ()
+queueTransfer reason schedule f t remote =
+	enqueue reason schedule t (stubInfo f remote)
+
+{- Blocks until the queue is no larger than a given size, and then adds a
+ - transfer to the queue. -}
+queueTransferAt :: Int -> Reason -> Schedule -> AssociatedFile -> Transfer -> Remote -> Assistant ()
+queueTransferAt wantsz reason schedule f t remote = do
+	q <- getAssistant transferQueue
+	liftIO $ atomically $ do
+		sz <- readTVar (queuesize q)
+		unless (sz <= wantsz) $
+			retry -- blocks until queuesize changes
+	enqueue reason schedule t (stubInfo f remote)
+
+queueTransferWhenSmall :: Reason -> AssociatedFile -> Transfer -> Remote -> Assistant ()
+queueTransferWhenSmall reason = queueTransferAt 10 reason Later
+
+{- Blocks until a pending transfer is available in the queue,
+ - and removes it.
+ -
+ - Checks that it's acceptable, before adding it to the
+ - currentTransfers map. If it's not acceptable, it's discarded.
+ -
+ - This is done in a single STM transaction, so there is no window
+ - where an observer sees an inconsistent status. -}
+getNextTransfer :: (TransferInfo -> Bool) -> Assistant (Maybe (Transfer, TransferInfo))
+getNextTransfer acceptable = do
+	q <- getAssistant transferQueue
+	dstatus <- getAssistant daemonStatusHandle
+	liftIO $ atomically $ do
+		sz <- readTVar (queuesize q)
+		if sz < 1
+			then retry -- blocks until queuesize changes
+			else do
+				(r@(t,info):rest) <- readTList (queuelist q)
+				void $ modifyTVar' (queuesize q) pred
+				setTList (queuelist q) rest
+				if acceptable info
+					then do
+						adjustTransfersSTM dstatus $
+							M.insertWith' const t info
+						return $ Just r
+					else return Nothing
+
+{- Moves transfers matching a condition from the queue, to the
+ - currentTransfers map. -}
+getMatchingTransfers :: (Transfer -> Bool) -> Assistant [(Transfer, TransferInfo)]
+getMatchingTransfers c = do
+	q <- getAssistant transferQueue
+	dstatus <- getAssistant daemonStatusHandle
+	liftIO $ atomically $ do
+		ts <- dequeueTransfersSTM q c
+		unless (null ts) $
+			adjustTransfersSTM dstatus $ \m -> M.union m $ M.fromList ts
+		return ts
+
+{- Removes transfers matching a condition from the queue, and returns the
+ - removed transfers. -}
+dequeueTransfers :: (Transfer -> Bool) -> Assistant [(Transfer, TransferInfo)]
+dequeueTransfers c = do
+	q <- getAssistant transferQueue
+	removed <- liftIO $ atomically $ dequeueTransfersSTM q c
+	unless (null removed) $
+		notifyTransfer
+	return removed
+
+dequeueTransfersSTM :: TransferQueue -> (Transfer -> Bool) -> STM [(Transfer, TransferInfo)]
+dequeueTransfersSTM q c = do
+	!(removed, ts) <- partition (c . fst) <$> readTList (queuelist q)
+	let !len = length ts
+	void $ writeTVar (queuesize q) len
+	setTList (queuelist q) ts
+	return removed

Assistant/TransferSlots.hs

@@ -0,0 +1,293 @@
+{- git-annex assistant transfer slots
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE CPP #-}
+
+module Assistant.TransferSlots where
+
+import Assistant.Common
+import Utility.ThreadScheduler
+import Assistant.Types.TransferSlots
+import Assistant.DaemonStatus
+import Assistant.TransferrerPool
+import Assistant.Types.TransferrerPool
+import Assistant.Types.TransferQueue
+import Assistant.TransferQueue
+import Assistant.Alert
+import Assistant.Alert.Utility
+import Assistant.Commits
+import Assistant.Drop
+import Logs.Transfer
+import Logs.Location
+import qualified Git
+import qualified Remote
+import qualified Types.Remote as Remote
+import Annex.Content
+import Annex.Wanted
+import Config.Files
+import Utility.Batch
+
+import qualified Data.Map as M 
+import qualified Control.Exception as E
+import Control.Concurrent
+import qualified Control.Concurrent.MSemN as MSemN
+#ifndef mingw32_HOST_OS
+import System.Posix.Process (getProcessGroupIDOf)
+import System.Posix.Signals (signalProcessGroup, sigTERM, sigKILL)
+#else
+import Utility.WinProcess
+#endif
+
+type TransferGenerator = Assistant (Maybe (Transfer, TransferInfo, Transferrer -> Assistant ()))
+
+{- Waits until a transfer slot becomes available, then runs a
+ - TransferGenerator, and then runs the transfer action in its own thread. 
+ -}
+inTransferSlot :: FilePath -> BatchCommandMaker -> TransferGenerator -> Assistant ()
+inTransferSlot program batchmaker gen = do
+	flip MSemN.wait 1 <<~ transferSlots
+	runTransferThread program batchmaker =<< gen
+
+{- Runs a TransferGenerator, and its transfer action,
+ - without waiting for a slot to become available. -}
+inImmediateTransferSlot :: FilePath -> BatchCommandMaker -> TransferGenerator -> Assistant ()
+inImmediateTransferSlot program batchmaker gen = do
+	flip MSemN.signal (-1) <<~ transferSlots
+	runTransferThread program batchmaker =<< gen
+
+{- Runs a transfer action, in an already allocated transfer slot.
+ - Once it finishes, frees the transfer slot.
+ -
+ - Note that the action is subject to being killed when the transfer
+ - is canceled or paused.
+ -
+ - A PauseTransfer exception is handled by letting the action be killed,
+ - then pausing the thread until a ResumeTransfer exception is raised,
+ - then rerunning the action.
+ -}
+runTransferThread :: FilePath -> BatchCommandMaker -> Maybe (Transfer, TransferInfo, Transferrer -> Assistant ()) -> Assistant ()
+runTransferThread _ _ Nothing = flip MSemN.signal 1 <<~ transferSlots
+runTransferThread program batchmaker (Just (t, info, a)) = do
+	d <- getAssistant id
+	aio <- asIO1 a
+	tid <- liftIO $ forkIO $ runTransferThread' program batchmaker d aio
+	updateTransferInfo t $ info { transferTid = Just tid }
+
+runTransferThread' :: FilePath -> BatchCommandMaker -> AssistantData -> (Transferrer -> IO ()) -> IO ()
+runTransferThread' program batchmaker d run = go
+  where
+	go = catchPauseResume $
+		withTransferrer program batchmaker (transferrerPool d)
+			run
+	pause = catchPauseResume $
+		runEvery (Seconds 86400) noop
+	{- Note: This must use E.try, rather than E.catch.
+	 - When E.catch is used, and has called go in its exception
+	 - handler, Control.Concurrent.throwTo will block sometimes
+	 - when signaling. Using E.try avoids the problem. -}
+	catchPauseResume a' = do
+		r <- E.try a' :: IO (Either E.SomeException ())
+		case r of
+			Left e -> case E.fromException e of
+				Just PauseTransfer -> pause
+				Just ResumeTransfer -> go
+				_ -> done
+			_ -> done
+	done = runAssistant d $ 
+		flip MSemN.signal 1 <<~ transferSlots
+
+{- By the time this is called, the daemonstatus's currentTransfers map should
+ - already have been updated to include the transfer. -}
+genTransfer :: Transfer -> TransferInfo -> TransferGenerator
+genTransfer t info = case transferRemote info of
+	Just remote 
+		| Git.repoIsLocalUnknown (Remote.repo remote) -> do
+			-- optimisation for removable drives not plugged in
+			liftAnnex $ recordFailedTransfer t info
+			void $ removeTransfer t
+			return Nothing
+		| otherwise -> ifM (liftAnnex $ shouldTransfer t info)
+			( do
+				debug [ "Transferring:" , describeTransfer t info ]
+				notifyTransfer
+				return $ Just (t, info, go remote)
+			, do
+				debug [ "Skipping unnecessary transfer:",
+					describeTransfer t info ]
+				void $ removeTransfer t
+				finishedTransfer t (Just info)
+				return Nothing
+			)
+	_ -> return Nothing
+  where
+	direction = transferDirection t
+	isdownload = direction == Download
+
+	{- Alerts are only shown for successful transfers.
+	 - Transfers can temporarily fail for many reasons,
+	 - so there's no point in bothering the user about
+	 - those. The assistant should recover.
+	 -
+	 - After a successful upload, handle dropping it from
+	 - here, if desired. In this case, the remote it was
+	 - uploaded to is known to have it.
+	 -
+	 - Also, after a successful transfer, the location
+	 - log has changed. Indicate that a commit has been
+	 - made, in order to queue a push of the git-annex
+	 - branch out to remotes that did not participate
+	 - in the transfer.
+	 -
+	 - If the process failed, it could have crashed,
+	 - so remove the transfer from the list of current
+	 - transfers, just in case it didn't stop
+	 - in a way that lets the TransferWatcher do its
+	 - usual cleanup. However, first check if something else is
+	 - running the transfer, to avoid removing active transfers.
+	 -}
+	go remote transferrer = ifM (liftIO $ performTransfer transferrer t $ associatedFile info)
+		( do
+			maybe noop
+				(void . addAlert . makeAlertFiller True 
+					. transferFileAlert direction True)
+				(associatedFile info)
+			unless isdownload $
+				handleDrops
+					("object uploaded to " ++ show remote)
+					True (transferKey t)
+					(associatedFile info)
+					(Just remote)
+			void recordCommit
+		, whenM (liftAnnex $ isNothing <$> checkTransfer t) $
+			void $ removeTransfer t
+		)
+
+{- Called right before a transfer begins, this is a last chance to avoid
+ - unnecessary transfers.
+ -
+ - For downloads, we obviously don't need to download if the already
+ - have the object.
+ -
+ - Smilarly, for uploads, check if the remote is known to already have
+ - the object.
+ -
+ - Also, uploads get queued to all remotes, in order of cost.
+ - This may mean, for example, that an object is uploaded over the LAN
+ - to a locally paired client, and once that upload is done, a more
+ - expensive transfer remote no longer wants the object. (Since
+ - all the clients have it already.) So do one last check if this is still
+ - preferred content.
+ -
+ - We'll also do one last preferred content check for downloads. An
+ - example of a case where this could be needed is if a download is queued
+ - for a file that gets moved out of an archive directory -- but before
+ - that download can happen, the file is put back in the archive.
+ -}
+shouldTransfer :: Transfer -> TransferInfo -> Annex Bool
+shouldTransfer t info
+	| transferDirection t == Download =
+		(not <$> inAnnex key) <&&> wantGet True (Just key) file
+	| transferDirection t == Upload = case transferRemote info of
+		Nothing -> return False
+		Just r -> notinremote r
+			<&&> wantSend True (Just key) file (Remote.uuid r)
+	| otherwise = return False
+  where
+	key = transferKey t
+	file = associatedFile info
+
+	{- Trust the location log to check if the remote already has
+	 - the key. This avoids a roundtrip to the remote. -}
+	notinremote r = notElem (Remote.uuid r) <$> loggedLocations key
+
+{- Queue uploads of files downloaded to us, spreading them
+ - out to other reachable remotes.
+ -
+ - Downloading a file may have caused a remote to not want it;
+ - so check for drops from remotes.
+ -
+ - Uploading a file may cause the local repo, or some other remote to not
+ - want it; handle that too.
+ -}
+finishedTransfer :: Transfer -> Maybe TransferInfo -> Assistant ()
+finishedTransfer t (Just info)
+	| transferDirection t == Download =
+		whenM (liftAnnex $ inAnnex $ transferKey t) $ do
+			dodrops False
+			void $ queueTransfersMatching (/= transferUUID t)
+				"newly received object"
+				Later (transferKey t) (associatedFile info) Upload
+	| otherwise = dodrops True
+  where
+	dodrops fromhere = handleDrops
+		("drop wanted after " ++ describeTransfer t info)
+		fromhere (transferKey t) (associatedFile info) Nothing
+finishedTransfer _ _ = noop
+
+{- Pause a running transfer. -}
+pauseTransfer :: Transfer -> Assistant ()
+pauseTransfer = cancelTransfer True
+
+{- Cancel a running transfer. -}
+cancelTransfer :: Bool -> Transfer -> Assistant ()
+cancelTransfer pause t = do
+	m <- getCurrentTransfers
+	unless pause $
+		{- remove queued transfer -}
+		void $ dequeueTransfers $ equivilantTransfer t
+	{- stop running transfer -}
+	maybe noop stop (M.lookup t m)
+  where
+	stop info = do
+		{- When there's a thread associated with the
+		 - transfer, it's signaled first, to avoid it
+		 - displaying any alert about the transfer having
+		 - failed when the transfer process is killed. -}
+		liftIO $ maybe noop signalthread $ transferTid info
+		liftIO $ maybe noop killproc $ transferPid info
+		if pause
+			then void $ alterTransferInfo t $
+				\i -> i { transferPaused = True }
+			else void $ removeTransfer t
+	signalthread tid
+		| pause = throwTo tid PauseTransfer
+		| otherwise = killThread tid
+	killproc pid = void $ tryIO $ do
+#ifndef mingw32_HOST_OS
+		{- In order to stop helper processes like rsync,
+		 - kill the whole process group of the process
+		 - running the transfer. -}
+		g <- getProcessGroupIDOf pid
+		let signal sig = void $ tryIO $ signalProcessGroup sig g
+		signal sigTERM
+		threadDelay 50000 -- 0.05 second grace period
+		signal sigKILL
+#else
+		terminatePID pid
+#endif
+
+{- Start or resume a transfer. -}
+startTransfer :: Transfer -> Assistant ()
+startTransfer t = do
+	m <- getCurrentTransfers
+	maybe startqueued go (M.lookup t m)
+  where
+	go info = maybe (start info) resume $ transferTid info
+	startqueued = do
+		is <- map snd <$> getMatchingTransfers (== t)
+		maybe noop start $ headMaybe is
+	resume tid = do
+		alterTransferInfo t $ \i -> i { transferPaused = False }
+		liftIO $ throwTo tid ResumeTransfer
+	start info = do
+		program <- liftIO readProgramFile
+		batchmaker <- liftIO getBatchCommandMaker
+		inImmediateTransferSlot program batchmaker $
+			genTransfer t info
+
+getCurrentTransfers :: Assistant TransferMap
+getCurrentTransfers = currentTransfers <$> getDaemonStatus

Assistant/TransferrerPool.hs

@@ -0,0 +1,97 @@
+{- A pool of "git-annex transferkeys" processes
+ -
+ - Copyright 2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Assistant.TransferrerPool where
+
+import Assistant.Common
+import Assistant.Types.TransferrerPool
+import Logs.Transfer
+import Utility.Batch
+
+import qualified Command.TransferKeys as T
+
+import Control.Concurrent.STM hiding (check)
+import System.Process (create_group, std_in, std_out)
+import Control.Exception (throw)
+import Control.Concurrent
+
+{- Runs an action with a Transferrer from the pool.
+ -
+ - Only one Transferrer is left running in the pool at a time.
+ - So if this needed to start a new Transferrer, it's stopped when done.
+ -}
+withTransferrer :: FilePath -> BatchCommandMaker -> TransferrerPool -> (Transferrer -> IO a) -> IO a
+withTransferrer program batchmaker pool a = do
+	(mi, leftinpool) <- atomically (popTransferrerPool pool)
+	i@(TransferrerPoolItem (Just t) check) <- case mi of
+		Nothing -> mkTransferrerPoolItem pool =<< mkTransferrer program batchmaker
+		Just i -> checkTransferrerPoolItem program batchmaker i
+	v <- tryNonAsync $ a t
+	if leftinpool == 0
+		then atomically $ pushTransferrerPool pool i
+		else do
+			void $ forkIO $ stopTransferrer t
+			atomically $ pushTransferrerPool pool $ TransferrerPoolItem Nothing check
+	either throw return v
+
+{- Check if a Transferrer from the pool is still ok to be used.
+ - If not, stop it and start a new one. -}
+checkTransferrerPoolItem :: FilePath -> BatchCommandMaker -> TransferrerPoolItem -> IO TransferrerPoolItem
+checkTransferrerPoolItem program batchmaker i = case i of
+	TransferrerPoolItem (Just t) check -> ifM check
+		( return i
+		, do
+			stopTransferrer t
+			new check
+		)
+	TransferrerPoolItem Nothing check -> new check
+  where
+	new check = do
+		t <- mkTransferrer program batchmaker
+		return $ TransferrerPoolItem (Just t) check
+
+{- Requests that a Transferrer perform a Transfer, and waits for it to
+ - finish. -}
+performTransfer :: Transferrer -> Transfer -> AssociatedFile -> IO Bool
+performTransfer transferrer t f = catchBoolIO $ do
+	T.sendRequest t f (transferrerWrite transferrer)
+	T.readResponse (transferrerRead transferrer)
+
+{- Starts a new git-annex transferkeys process, setting up handles
+ - that will be used to communicate with it. -}
+mkTransferrer :: FilePath -> BatchCommandMaker -> IO Transferrer
+mkTransferrer program batchmaker = do
+	{- It runs as a batch job. -}
+	let (program', params') = batchmaker (program, [Param "transferkeys"])
+	{- It's put into its own group so that the whole group can be
+	 - killed to stop a transfer. -}
+	(Just writeh, Just readh, _, pid) <- createProcess
+		(proc program' $ toCommand params')
+		{ create_group = True
+		, std_in = CreatePipe
+		, std_out = CreatePipe
+		}
+	fileEncoding readh
+	fileEncoding writeh
+	return $ Transferrer
+		{ transferrerRead = readh
+		, transferrerWrite = writeh
+		, transferrerHandle = pid
+		}
+
+{- Checks if a Transferrer is still running. If not, makes a new one. -}
+checkTransferrer :: FilePath -> BatchCommandMaker -> Transferrer -> IO Transferrer
+checkTransferrer program batchmaker t =
+	maybe (return t) (const $ mkTransferrer program batchmaker)
+		=<< getProcessExitCode (transferrerHandle t)
+
+{- Closing the fds will stop the transferrer. -}
+stopTransferrer :: Transferrer -> IO ()
+stopTransferrer t = do
+	hClose $ transferrerRead t
+	hClose $ transferrerWrite t
+	void $ waitForProcess $ transferrerHandle t

Assistant/Types/Alert.hs

@@ -0,0 +1,79 @@
+{- git-annex assistant alert types
+ -
+ - Copyright 2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Assistant.Types.Alert where
+
+import Utility.Tense
+
+import Data.Text (Text)
+import qualified Data.Map as M
+
+{- Different classes of alerts are displayed differently. -}
+data AlertClass = Success | Message | Activity | Warning | Error
+	deriving (Eq, Ord)
+
+data AlertPriority = Filler | Low | Medium | High | Pinned
+	deriving (Eq, Ord)
+
+{- An alert can have an name, which is used to combine it with other similar
+ - alerts. -}
+data AlertName 
+	= FileAlert TenseChunk
+	| SanityCheckFixAlert
+	| WarningAlert String
+	| PairAlert String
+	| XMPPNeededAlert
+	| RemoteRemovalAlert String
+	| CloudRepoNeededAlert
+	| SyncAlert
+	| NotFsckedAlert
+	| UpgradeAlert
+	| UnusedFilesAlert
+	deriving (Eq)
+
+{- The first alert is the new alert, the second is an old alert.
+ - Should return a modified version of the old alert. -}
+type AlertCombiner = Alert -> Alert -> Maybe Alert
+
+data Alert = Alert
+	{ alertClass :: AlertClass
+	, alertHeader :: Maybe TenseText
+	, alertMessageRender :: Alert -> TenseText
+	, alertData :: [TenseChunk]
+	, alertCounter :: Int
+	, alertBlockDisplay :: Bool
+	, alertClosable :: Bool
+	, alertPriority :: AlertPriority
+	, alertIcon :: Maybe AlertIcon
+	, alertCombiner :: Maybe AlertCombiner
+	, alertName :: Maybe AlertName
+	, alertButtons :: [AlertButton]
+	}
+
+data AlertIcon = ActivityIcon | SyncIcon | SuccessIcon | ErrorIcon | InfoIcon | UpgradeIcon | TheCloud
+
+type AlertMap = M.Map AlertId Alert
+
+{- Higher AlertId indicates a more recent alert. -}
+newtype AlertId = AlertId Integer
+	deriving (Read, Show, Eq, Ord)
+
+firstAlertId :: AlertId
+firstAlertId = AlertId 0
+
+nextAlertId :: AlertId -> AlertId
+nextAlertId (AlertId i) = AlertId $ succ i
+
+{- When clicked, a button always redirects to a URL
+ - It may also run an IO action in the background, which is useful
+ - to make the button close or otherwise change the alert. -}
+data AlertButton = AlertButton
+	{ buttonLabel :: Text
+	, buttonUrl :: Text
+	, buttonAction :: Maybe (AlertId -> IO ())
+	, buttonPrimary :: Bool
+	}

Assistant/Types/BranchChange.hs

@@ -0,0 +1,19 @@
+{- 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.Types.BranchChange where
+
+import Control.Concurrent.MSampleVar
+import Common.Annex
+
+newtype BranchChangeHandle = BranchChangeHandle (MSampleVar ())
+
+newBranchChangeHandle :: IO BranchChangeHandle
+newBranchChangeHandle = BranchChangeHandle <$> newEmptySV
+
+fromBranchChangeHandle :: BranchChangeHandle -> MSampleVar ()
+fromBranchChangeHandle (BranchChangeHandle v) = v