Record git-annex (5.20131127) in archive suite sid

.gitattributes

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

.gitignore

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

Annex.hs

@@ -5,14 +5,13 @@
  - Licensed under the GNU GPL version 3 or higher.
  -}
 
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving, PackageImports #-}
 
 module Annex (
 	Annex,
 	AnnexState(..),
 	PreferredContentMap,
 	new,
-	newState,
 	run,
 	eval,
 	getState,
@@ -41,6 +40,7 @@ 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
@@ -111,10 +111,10 @@ data AnnexState = AnnexState
 	, useragent :: Maybe String
 	}
 
-newState :: Git.Repo -> AnnexState
+newState :: GitConfig -> Git.Repo -> AnnexState
-newState gitrepo = AnnexState
+newState c r = AnnexState
-	{ repo = gitrepo
+	{ repo = r
-	, gitconfig = extractGitConfig gitrepo
+	, gitconfig = c
 	, backends = []
 	, remotes = []
 	, output = defaultMessageState
@@ -148,7 +148,10 @@ newState gitrepo = AnnexState
 {- 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 = newState <$$> Git.Config.read
+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. -}

Annex/Branch.hs

@@ -29,6 +29,7 @@ module Annex.Branch (
 import qualified Data.ByteString.Lazy.Char8 as L
 import qualified Data.Set as S
 import qualified Data.Map as M
+import qualified Control.Exception as E
 
 import Common.Annex
 import Annex.BranchState
@@ -53,6 +54,7 @@ import Logs.Trust.Pure
 import Annex.ReplaceFile
 import qualified Annex.Queue
 import Annex.Branch.Transitions
+import Annex.Exception
 
 {- Name of the branch that is used to store git-annex's information. -}
 name :: Git.Ref
@@ -345,15 +347,15 @@ withIndex' bootstrapping a = do
 #endif
 	let g' = g { gitEnv = Just $ ("GIT_INDEX_FILE", f):e }
 
+	r <- tryAnnex $ do
 		Annex.changeState $ \s -> s { Annex.repo = g' }
 		checkIndexOnce $ unlessM (liftIO $ doesFileExist f) $ do
 			unless bootstrapping create
-		liftIO $ createDirectoryIfMissing True $ takeDirectory f
+			createAnnexDirectory $ takeDirectory f
 			unless bootstrapping $ inRepo genIndex
-	r <- a
+		a
 	Annex.changeState $ \s -> s { Annex.repo = (Annex.repo s) { gitEnv = gitEnv g} }
-
+	either E.throw return r
-	return r
 
 {- Updates the branch's index to reflect the current contents of the branch.
  - Any changes staged in the index will be preserved.
@@ -384,7 +386,7 @@ setIndexSha :: Git.Ref -> Annex ()
 setIndexSha ref = do
 	f <- fromRepo gitAnnexIndexStatus
 	liftIO $ writeFile f $ show ref ++ "\n"
-	setAnnexPerm f
+	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

Annex/CatFile.hs

@@ -27,6 +27,7 @@ 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
@@ -108,9 +109,6 @@ catKeyChecked needhead ref@(Ref r) =
 		 map snd . filter (\p -> fst p == file)
 
 {- From a file in the repository back to the key.
- -
- - Prefixing the file with ./ makes this work even if in a subdirectory
- - of a repo.
  -
  - Ideally, this should reflect the key that's staged in the index,
  - not the key that's committed to HEAD. Unfortunately, git cat-file
@@ -134,8 +132,8 @@ catKeyChecked needhead ref@(Ref r) =
 catKeyFile :: FilePath -> Annex (Maybe Key)
 catKeyFile f = ifM (Annex.getState Annex.daemon)
 	( catKeyFileHEAD f
-	, catKeyChecked True (Ref $ ":./" ++ f)
+	, catKeyChecked True $ Git.Ref.fileRef f
 	)
 
 catKeyFileHEAD :: FilePath -> Annex (Maybe Key)
-catKeyFileHEAD f = catKeyChecked False (Ref $ "HEAD:./" ++ f)
+catKeyFileHEAD f = catKeyChecked False $ Git.Ref.fileFromRef Git.Ref.headRef f

Annex/Content.hs

@@ -29,8 +29,8 @@ module Annex.Content (
 	preseedTmp,
 	freezeContent,
 	thawContent,
-	cleanObjectLoc,
 	dirKeys,
+	withObjectLoc,
 ) where
 
 import System.IO.Unsafe (unsafeInterleaveIO)
@@ -54,9 +54,7 @@ import Annex.Perms
 import Annex.Link
 import Annex.Content.Direct
 import Annex.ReplaceFile
-#ifndef mingw32_HOST_OS
 import Annex.Exception
-#endif
 
 {- Checks if a given key's content is currently present. -}
 inAnnex :: Key -> Annex Bool
@@ -255,11 +253,9 @@ moveAnnex key src = withObjectLoc key storeobject storedirect
   where
 	storeobject dest = ifM (liftIO $ doesFileExist dest)
 		( alreadyhave
-		, do
+		, modifyContent dest $ do
-			createContentDir dest
 			liftIO $ moveFile src dest
 			freezeContent dest
-			freezeContentDir dest
 		)
 	storeindirect = storeobject =<< calcRepo (gitAnnexLocation key)
 
@@ -273,7 +269,6 @@ moveAnnex key src = withObjectLoc key storeobject storedirect
 	storedirect = storedirect' storeindirect
 	storedirect' fallback [] = fallback
 	storedirect' fallback (f:fs) = do
-		thawContentDir =<< calcRepo (gitAnnexLocation key)
 		thawContent src
 		v <- isAnnexLink f
 		if Just key == v
@@ -349,11 +344,11 @@ withObjectLoc key indirect direct = ifM isDirect
   where
 	goindirect = indirect =<< calcRepo (gitAnnexLocation key)
 
-cleanObjectLoc :: Key -> Annex ()
+cleanObjectLoc :: Key -> Annex () -> Annex ()
-cleanObjectLoc key = do
+cleanObjectLoc key cleaner = do
 	file <- calcRepo $ gitAnnexLocation key
-	unlessM crippledFileSystem $
+	void $ tryAnnexIO $ thawContentDir file
-		void $ liftIO $ catchMaybeIO $ allowWrite $ parentDir file
+	cleaner
 	liftIO $ removeparents file (3 :: Int)
   where
 	removeparents _ 0 = noop
@@ -369,13 +364,10 @@ cleanObjectLoc key = do
 removeAnnex :: Key -> Annex ()
 removeAnnex key = withObjectLoc key remove removedirect
   where
-	remove file = do
+	remove file = cleanObjectLoc key $ do
-		thawContentDir file
 		liftIO $ nukeFile file
 		removeInodeCache key
-		cleanObjectLoc key
 	removedirect fs = do
-		thawContentDir =<< calcRepo (gitAnnexLocation key)
 		cache <- recordedInodeCache key
 		removeInodeCache key
 		mapM_ (resetfile cache) fs
@@ -389,12 +381,10 @@ removeAnnex key = withObjectLoc key remove removedirect
 
 {- Moves a key's file out of .git/annex/objects/ -}
 fromAnnex :: Key -> FilePath -> Annex ()
-fromAnnex key dest = do
+fromAnnex key dest = cleanObjectLoc key $ do
 	file <- calcRepo $ gitAnnexLocation key
-	thawContentDir file
 	thawContent file
 	liftIO $ moveFile file dest
-	cleanObjectLoc key
 
 {- Moves a key out of .git/annex/objects/ into .git/annex/bad, and
  - returns the file it was moved to. -}
@@ -404,9 +394,8 @@ moveBad key = do
 	bad <- fromRepo gitAnnexBadDir
 	let dest = bad </> takeFileName src
 	createAnnexDirectory (parentDir dest)
-	thawContentDir src
+	cleanObjectLoc key $
 		liftIO $ moveFile src dest
-	cleanObjectLoc key
 	logStatus key InfoMissing
 	return dest
 

Annex/Content/Direct.hs

@@ -10,6 +10,7 @@ module Annex.Content.Direct (
 	associatedFilesRelative,
 	removeAssociatedFile,
 	removeAssociatedFileUnchecked,
+	removeAssociatedFiles,
 	addAssociatedFile,
 	goodContent,
 	recordedInodeCache,
@@ -64,7 +65,7 @@ changeAssociatedFiles key transform = do
 	files <- associatedFilesRelative key
 	let files' = transform files
 	when (files /= files') $ do
-		createContentDir mapping
+		modifyContent mapping $
 			liftIO $ viaTmp write mapping $ unlines files'
 	top <- fromRepo Git.repoPath
 	return $ map (top </>) files'
@@ -75,6 +76,13 @@ changeAssociatedFiles key transform = do
  		hPutStr h content
 		hClose h
 
+{- 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. -}
@@ -142,15 +150,15 @@ addInodeCache key cache = do
 
 {- Writes inode cache for a key. -}
 writeInodeCache :: Key -> [InodeCache] -> Annex ()
-writeInodeCache key caches = withInodeCacheFile key $ \f -> do
+writeInodeCache key caches = withInodeCacheFile key $ \f -> 
-	createContentDir f
+	modifyContent f $
 		liftIO $ writeFile f $
 			unlines $ map showInodeCache caches
 
 {- Removes an inode cache. -}
 removeInodeCache :: Key -> Annex ()
-removeInodeCache key = withInodeCacheFile key $ \f -> do
+removeInodeCache key = withInodeCacheFile key $ \f ->
-	createContentDir f -- also thaws directory
+	modifyContent f $
 		liftIO $ nukeFile f
 
 withInodeCacheFile :: Key -> (FilePath -> Annex a) -> Annex a

Annex/Direct.hs

@@ -8,13 +8,18 @@
 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
@@ -133,28 +138,33 @@ mergeDirect d branch g = do
  - 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 really add the directory until the file with the
+ - same name is remvoed.
  -}
 mergeDirectCleanup :: FilePath -> Git.Ref -> Git.Ref -> Annex ()
 mergeDirectCleanup d oldsha newsha = do
 	(items, cleanup) <- inRepo $ DiffTree.diffTreeRecursive oldsha newsha
 	makeabs <- flip fromTopFilePath <$> gitRepo
-	forM_ items (updated makeabs)
+	let fsitems = zip (map (makeabs . DiffTree.file) items) items
+	forM_ fsitems $
+		go DiffTree.srcsha DiffTree.srcmode moveout moveout_raw
+	forM_ fsitems $
+		go DiffTree.dstsha DiffTree.dstmode movein movein_raw
 	void $ liftIO cleanup
 	liftIO $ removeDirectoryRecursive d
   where
-	updated makeabs item = do
+	go getsha getmode a araw (f, item)
-		let f = makeabs (DiffTree.file item)
-		void $ tryAnnex $
-			go f DiffTree.srcsha DiffTree.srcmode moveout moveout_raw
-		void $ tryAnnex $ 
-			go f DiffTree.dstsha DiffTree.dstmode movein movein_raw
-	  where
-		go f getsha getmode a araw
 		| getsha item == nullSha = noop
-			| otherwise = maybe (araw f) (\k -> void $ a k f)
+		| otherwise = void $
+			tryAnnex . maybe (araw f) (\k -> void $ a k f)
 				=<< catKey (getsha item) (getmode item)
 
-	moveout = removeDirect
+	moveout k f = removeDirect k f
 
 	{- Files deleted by the merge are removed from the work tree.
 	 - Empty work tree directories are removed, per git behavior. -}
@@ -200,9 +210,9 @@ toDirectGen k f = do
   where
   	fromindirect loc = do
 		{- Move content from annex to direct file. -}
-		thawContentDir loc
 		updateInodeCache k loc
 		void $ addAssociatedFile k f
+		modifyContent loc $ do
 			thawContent loc
 			replaceFile f $ liftIO . moveFile loc
 	fromdirect loc = do
@@ -231,3 +241,66 @@ 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 "/" $ show orighead of
+	("refs":"heads":"annex":"direct":_) -> orighead
+	("refs":"heads":rest) ->
+		Ref $ "refs/heads/annex/direct/" ++ intercalate "/" rest
+	_ -> Ref $ "refs/heads/" ++ show (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 "/" $ show 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/Exception.hs

@@ -10,6 +10,8 @@
  - Licensed under the GNU GPL version 3 or higher.
  -}
 
+{-# LANGUAGE PackageImports #-}
+
 module Annex.Exception (
 	bracketIO,
 	tryAnnex,

Annex/Hook.hs

@@ -0,0 +1,42 @@
+{- git-annex git hooks
+ -
+ - Note that it's important that the scripts not change, otherwise
+ - removing old hooks using an old version of the script would fail.
+ -
+ - Copyright 2013 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 Utility.Shell
+import Config
+
+preCommitHook :: Git.Hook
+preCommitHook = Git.Hook "pre-commit" (mkHookScript "git annex pre-commit .")
+
+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

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

@@ -6,19 +6,22 @@
  -}
 
 module Annex.Perms (
-	setAnnexPerm,
+	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
@@ -31,17 +34,27 @@ withShared a = maybe startup a =<< Annex.getState Annex.shared
 		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 :: FilePath -> Annex ()
+setAnnexPerm :: Bool -> FilePath -> Annex ()
-setAnnexPerm file = unlessM crippledFileSystem $
+setAnnexPerm isdir file = unlessM crippledFileSystem $
 	withShared $ liftIO . go
   where
-	go GroupShared = groupWriteRead file
+	go GroupShared = modifyFileMode file $ addModes $
+		groupSharedModes ++
+		if isdir then [ ownerExecuteMode, groupExecuteMode ] else []
 	go AllShared = modifyFileMode file $ addModes $
-		[ ownerWriteMode, groupWriteMode ] ++ readModes
+		readModes ++
+		[ ownerWriteMode, groupWriteMode ] ++
+		if isdir then executeModes else []
 	go _ = noop
 
 {- Gets the appropriate mode to use for creating a file in the annex
@@ -52,10 +65,7 @@ annexFileMode = withShared $ return . go
 	go GroupShared = sharedmode
 	go AllShared = combineModes (sharedmode:readModes)
 	go _ = stdFileMode
-	sharedmode = combineModes
+	sharedmode = combineModes groupSharedModes
-		[ ownerWriteMode, groupWriteMode
-		, ownerReadMode, groupReadMode
-		]
 
 {- Creates a directory inside the gitAnnexDir, including any parent
  - directories. Makes directories with appropriate permissions. -}
@@ -72,7 +82,7 @@ createAnnexDirectory dir = traverse dir [] =<< top
 	  where
 		done = forM_ below $ \p -> do
 			liftIO $ createDirectoryIfMissing True p
-			setAnnexPerm p
+			setAnnexDirPerm p
 
 {- Blocks writing to the directory an annexed file is in, to prevent the
  - file accidentially being deleted. However, if core.sharedRepository
@@ -103,3 +113,13 @@ createContentDir dest = do
 		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/Version.hs

@@ -19,18 +19,21 @@ defaultVersion :: Version
 defaultVersion = "3"
 
 directModeVersion :: Version
-directModeVersion = "4"
+directModeVersion = "5"
 
 supportedVersions :: [Version]
 supportedVersions = [defaultVersion, directModeVersion]
 
 upgradableVersions :: [Version]
 #ifndef mingw32_HOST_OS
-upgradableVersions = ["0", "1", "2"]
+upgradableVersions = ["0", "1", "2", "4"]
 #else
-upgradableVersions = ["2"]
+upgradableVersions = ["2", "4"]
 #endif
 
+autoUpgradeableVersions :: [Version]
+autoUpgradeableVersions = ["4"]
+
 versionField :: ConfigKey
 versionField = annexConfig "version"
 
@@ -42,12 +45,3 @@ setVersion = setConfig versionField
 
 removeVersion :: Annex ()
 removeVersion = unsetConfig versionField
-
-checkVersion :: Version -> Annex ()
-checkVersion v
-	| v `elem` supportedVersions = noop
-	| v `elem` upgradableVersions = err "Upgrade this repository: git-annex upgrade"
-	| otherwise = err "Upgrade git-annex."
-  where
-	err msg = error $ "Repository version " ++ v ++
-		" is not supported. " ++ msg

Assistant.hs

@@ -28,6 +28,8 @@ import Assistant.Threads.ProblemFixer
 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
@@ -50,6 +52,7 @@ import qualified Utility.Daemon
 import Utility.LogFile
 import Utility.ThreadScheduler
 import Utility.HumanTime
+import Annex.Perms
 import qualified Build.SysConfig as SysConfig
 
 import System.Log.Logger
@@ -63,11 +66,13 @@ stopDaemon = liftIO . Utility.Daemon.stopDaemon =<< fromRepo gitAnnexPidFile
  -
  - startbrowser is passed the url and html shim file, as well as the original
  - stdout and stderr descriptors. -}
-startDaemon :: Bool -> Bool -> Maybe Duration -> Maybe HostName ->  Maybe (Maybe Handle -> Maybe Handle -> String -> FilePath -> IO ()) -> Annex ()
+startDaemon :: Bool -> Bool -> Maybe Duration -> Maybe String -> Maybe HostName ->  Maybe (Maybe Handle -> Maybe Handle -> String -> FilePath -> IO ()) -> Annex ()
-startDaemon assistant foreground startdelay listenhost startbrowser = do
+startDaemon assistant foreground startdelay cannotrun listenhost startbrowser = do
 	Annex.changeState $ \s -> s { Annex.daemon = True }
 	pidfile <- fromRepo gitAnnexPidFile
 	logfile <- fromRepo gitAnnexLogFile
+#ifndef mingw32_HOST_OS
+	createAnnexDirectory (parentDir logfile)
 	logfd <- liftIO $ openLog logfile
 	if foreground
 		then do
@@ -86,6 +91,13 @@ startDaemon assistant foreground startdelay listenhost startbrowser = do
 					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.
+	start id $
+		case startbrowser of
+			Nothing -> Nothing
+			Just a -> Just $ a Nothing Nothing
+#endif
   where
   	desc
 		| assistant = "assistant"
@@ -99,7 +111,6 @@ startDaemon assistant foreground startdelay listenhost startbrowser = do
 			flip runAssistant (go webappwaiter) 
 				=<< newAssistantData st dstatus
 
-
 #ifdef WITH_WEBAPP
 	go webappwaiter = do
 		d <- getAssistant id
@@ -108,10 +119,16 @@ startDaemon assistant foreground startdelay listenhost startbrowser = do
 #endif
 		notice ["starting", desc, "version", SysConfig.packageversion]
 		urlrenderer <- liftIO newUrlRenderer
-		mapM_ (startthread urlrenderer)
+#ifdef WITH_WEBAPP
+		let webappthread = [ assist $ webAppThread d urlrenderer False cannotrun listenhost Nothing webappwaiter ]
+#else
+		let webappthread = []
+#endif
+		let threads = if isJust cannotrun
+			then webappthread
+			else webappthread ++
 				[ watch $ commitThread
 #ifdef WITH_WEBAPP
-			, assist $ webAppThread d urlrenderer False listenhost Nothing webappwaiter
 #ifdef WITH_PAIRING
 				, assist $ pairListenerThread urlrenderer
 #endif
@@ -135,6 +152,8 @@ startDaemon assistant foreground startdelay listenhost startbrowser = do
 				, assist $ mountWatcherThread urlrenderer
 #endif
 				, assist $ netWatcherThread
+				, assist $ upgraderThread urlrenderer
+				, assist $ upgradeWatcherThread urlrenderer
 				, assist $ netWatcherFallbackThread
 				, assist $ transferScannerThread urlrenderer
 				, assist $ cronnerThread urlrenderer
@@ -146,6 +165,7 @@ startDaemon assistant foreground startdelay listenhost startbrowser = do
 				, watch $ sanityCheckerStartupThread startdelay
 				]
 	
+		mapM_ (startthread urlrenderer) threads
 		liftIO waitForTermination
 
 	watch a = (True, a)

Assistant/Alert.hs

@@ -15,6 +15,7 @@ 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
@@ -42,6 +43,7 @@ mkAlertButton autoclose label urlrenderer route = do
 		{ buttonLabel = label
 		, buttonUrl = url
 		, buttonAction = if autoclose then Just close else Nothing
+		, buttonPrimary = True
 		}
 #endif
 
@@ -61,7 +63,7 @@ baseActivityAlert = Alert
 	, alertIcon = Just ActivityIcon
 	, alertCombiner = Nothing
 	, alertName = Nothing
-	, alertButton = Nothing
+	, alertButtons = []
 	}
 
 warningAlert :: String -> String -> Alert
@@ -77,11 +79,11 @@ warningAlert name msg = Alert
 	, alertIcon = Just ErrorIcon
 	, alertCombiner = Just $ dataCombiner $ \_old new -> new
 	, alertName = Just $ WarningAlert name
-	, alertButton = Nothing
+	, alertButtons = []
 	}
 
-errorAlert :: String -> AlertButton -> Alert
+errorAlert :: String -> [AlertButton] -> Alert
-errorAlert msg button = Alert
+errorAlert msg buttons = Alert
 	{ alertClass = Error
 	, alertHeader = Nothing
 	, alertMessageRender = renderData
@@ -93,7 +95,7 @@ errorAlert msg button = Alert
 	, alertIcon = Just ErrorIcon
 	, alertCombiner = Nothing
 	, alertName = Nothing
-	, alertButton = Just button
+	, alertButtons = buttons
 	}
 
 activityAlert :: Maybe TenseText -> [TenseChunk] -> Alert
@@ -160,7 +162,7 @@ sanityCheckFixAlert msg = Alert
 	, alertIcon = Just ErrorIcon
 	, alertName = Just SanityCheckFixAlert
 	, alertCombiner = Just $ dataCombiner (++)
-	, alertButton = Nothing
+	, alertButtons = []
 	}
   where
 	render alert = tenseWords $ alerthead : alertData alert ++ [alertfoot]
@@ -172,7 +174,7 @@ 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"]
-	, alertButton = Just button
+	, alertButtons = [button]
 	}
 
 showFscking :: UrlRenderer -> Maybe Remote -> IO (Either E.SomeException a) -> Assistant a
@@ -192,7 +194,7 @@ notFsckedNudge urlrenderer mr = do
 	button <- mkAlertButton True (T.pack "Configure") urlrenderer ConfigFsckR
 	void $ addAlert (notFsckedAlert mr button)
 #else
-notFsckedNudge _ = noop
+notFsckedNudge _ _ = noop
 #endif
 
 notFsckedAlert :: Maybe Remote -> AlertButton -> Alert
@@ -204,7 +206,7 @@ notFsckedAlert mr button = Alert
 		]
 	, alertIcon = Just InfoIcon
 	, alertPriority = High
-	, alertButton = Just button
+	, alertButtons = [button]
 	, alertClosable = True
 	, alertClass = Message
 	, alertMessageRender = renderData
@@ -215,7 +217,50 @@ notFsckedAlert mr button = Alert
 	, alertData = []
 	}
 
-brokenRepositoryAlert :: AlertButton -> Alert
+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 (maybe [] (:[]) button) $ fromString $ 
+		"Finished upgrading git-annex to version " ++ version
+
+upgradeFailedAlert :: String -> Alert
+upgradeFailedAlert msg = (errorAlert msg [])
+	{ alertHeader = Just $ fromString "Upgrade failed." }
+
+brokenRepositoryAlert :: [AlertButton] -> Alert
 brokenRepositoryAlert = errorAlert "Serious problems have been detected with your repository. This needs your immediate attention!"
 
 repairingAlert :: String -> Alert
@@ -228,7 +273,7 @@ pairingAlert :: AlertButton -> Alert
 pairingAlert button = baseActivityAlert
 	{ alertData = [ UnTensed "Pairing in progress" ]
 	, alertPriority = High
-	, alertButton = Just button
+	, alertButtons = [button]
 	}
 
 pairRequestReceivedAlert :: String -> AlertButton -> Alert
@@ -244,7 +289,7 @@ pairRequestReceivedAlert who button = Alert
 	, alertIcon = Just InfoIcon
 	, alertName = Just $ PairAlert who
 	, alertCombiner = Just $ dataCombiner $ \_old new -> new
-	, alertButton = Just button
+	, alertButtons = [button]
 	}
 
 pairRequestAcknowledgedAlert :: String -> Maybe AlertButton -> Alert
@@ -253,7 +298,7 @@ pairRequestAcknowledgedAlert who button = baseActivityAlert
 	, alertPriority = High
 	, alertName = Just $ PairAlert who
 	, alertCombiner = Just $ dataCombiner $ \_old new -> new
-	, alertButton = button
+	, alertButtons = maybe [] (:[]) button
 	}
 
 xmppNeededAlert :: AlertButton -> Alert
@@ -261,7 +306,7 @@ xmppNeededAlert button = Alert
 	{ alertHeader = Just "Share with friends, and keep your devices in sync across the cloud."
 	, alertIcon = Just TheCloud
 	, alertPriority = High
-	, alertButton = Just button
+	, alertButtons = [button]
 	, alertClosable = True
 	, alertClass = Message
 	, alertMessageRender = renderData
@@ -280,7 +325,7 @@ cloudRepoNeededAlert friendname button = Alert
 		]
 	, alertIcon = Just ErrorIcon
 	, alertPriority = High
-	, alertButton = Just button
+	, alertButtons = [button]
 	, alertClosable = True
 	, alertClass = Message
 	, alertMessageRender = renderData
@@ -298,7 +343,7 @@ remoteRemovalAlert desc button = Alert
 		"\" has been emptied, and can now be removed."
 	, alertIcon = Just InfoIcon
 	, alertPriority = High
-	, alertButton = Just button
+	, alertButtons = [button]
 	, alertClosable = True
 	, alertClass = Message
 	, alertMessageRender = renderData

Assistant/Alert/Utility.hs

@@ -87,7 +87,7 @@ makeAlertFiller success alert
 		{ alertClass = if c == Activity then c' else c
 		, alertPriority = Filler
 		, alertClosable = True
-		, alertButton = Nothing
+		, alertButtons = []
 		, alertIcon = Just $ if success then SuccessIcon else ErrorIcon
 		}
   where

Assistant/MakeRemote.hs

@@ -20,6 +20,7 @@ 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)

Assistant/NamedThread.hs

@@ -82,7 +82,7 @@ startNamedThread urlrenderer (NamedThread afterstartupsanitycheck name a) = do
 					(RestartThreadR name)
 				runAssistant d $ void $ addAlert $
 					(warningAlert (fromThreadName name) msg)
-						{ alertButton = Just button }
+						{ alertButtons = [button] }
 #endif
 
 namedThreadId :: NamedThread -> Assistant (Maybe ThreadId)

Assistant/Pairing.hs

@@ -28,7 +28,7 @@ data PairStage
 	| PairAck
 	{- "I saw your PairAck; you can stop sending them." -}
 	| PairDone
-	deriving (Eq, Read, Show, Ord)
+	deriving (Eq, Read, Show, Ord, Enum)
 
 newtype PairMsg = PairMsg (Verifiable (PairStage, PairData, SomeAddr))
 	deriving (Eq, Read, Show)

Assistant/Repair.hs

@@ -46,7 +46,7 @@ repairWhenNecessary urlrenderer u mrmt fsckresults
 		unless ok $ do
 			button <- mkAlertButton True (T.pack "Click Here") urlrenderer $
 				RepairRepositoryR u
-			void $ addAlert $ brokenRepositoryAlert button
+			void $ addAlert $ brokenRepositoryAlert [button]
 #endif
 		return ok
 	| otherwise = return False

Assistant/Restart.hs

@@ -0,0 +1,86 @@
+{- git-annex assistant restarting
+ -
+ - Copyright 2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU AGPL version 3 or higher.
+ -}
+
+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 qualified Git.Construct
+import qualified Git.Config
+import Config.Files
+import qualified Annex
+import qualified Git
+
+import Control.Concurrent
+import System.Posix (getProcessID, signalProcess, sigTERM)
+import System.Process (cwd)
+
+{- 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)
+		signalProcess sigTERM =<< getProcessID
+
+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 (listening url)
+				( return url
+				, delayed $ waiturl urlfile
+				)
+	listening url = catchBoolIO $ fst <$> exists url [] Nothing
+	delayed a = do
+		threadDelay 100000 -- 1/10th of a second
+		a
+
+{- Returns once the assistant has daemonized, but possibly before it's
+ - listening for web connections. -}
+startAssistant :: FilePath -> IO ()
+startAssistant repo = do
+	program <- readProgramFile
+	(_, _, _, pid) <- 
+		createProcess $
+			(proc program ["assistant"]) { cwd = Just repo }
+	void $ checkSuccessProcess pid

Assistant/Ssh.hs

@@ -12,6 +12,7 @@ import Utility.Tmp
 import Utility.UserInfo
 import Utility.Shell
 import Utility.Rsync
+import Utility.FileMode
 import Git.Remote
 
 import Data.Text (Text)
@@ -233,12 +234,8 @@ setupSshKeyPair sshkeypair sshdata = do
 	sshdir <- sshDir
 	createDirectoryIfMissing True $ parentDir $ sshdir </> sshprivkeyfile
 
-	unlessM (doesFileExist $ sshdir </> sshprivkeyfile) $ do
+	unlessM (doesFileExist $ sshdir </> sshprivkeyfile) $
-		h <- fdToHandle =<<
+		writeFileProtected (sshdir </> sshprivkeyfile) (sshPrivKey sshkeypair)
-			createFile (sshdir </> sshprivkeyfile)
-				(unionFileModes ownerWriteMode ownerReadMode)
-		hPutStr h (sshPrivKey sshkeypair)
-		hClose h
 	unlessM (doesFileExist $ sshdir </> sshpubkeyfile) $
 		writeFile (sshdir </> sshpubkeyfile) (sshPubKey sshkeypair)
 

Assistant/Threads/NetWatcher.hs

@@ -15,6 +15,7 @@ import Assistant.Sync
 import Utility.ThreadScheduler
 import qualified Types.Remote as Remote
 import Assistant.DaemonStatus
+import Utility.NotificationBroadcaster
 
 #if WITH_DBUS
 import Utility.DBus
@@ -127,7 +128,9 @@ listenWicdConnections client callback =
 #endif
 
 handleConnection :: Assistant ()
-handleConnection = reconnectRemotes True =<< networkRemotes
+handleConnection = do
+	liftIO . sendNotification . networkConnectedNotifier =<< getDaemonStatus
+	reconnectRemotes True =<< networkRemotes
 
 {- Network remotes to sync with. -}
 networkRemotes :: Assistant [Remote]

Assistant/Threads/PairListener.hs

@@ -16,6 +16,7 @@ import Assistant.WebApp.Types
 import Assistant.Alert
 import Assistant.DaemonStatus
 import Utility.ThreadScheduler
+import Utility.Format
 import Git
 
 import Network.Multicast
@@ -42,20 +43,32 @@ pairListenerThread urlrenderer = namedThread "PairListener" $ do
 			(pip, verified) <- verificationCheck m
 				=<< (pairingInProgress <$> getDaemonStatus)
 			let wrongstage = maybe False (\p -> pairMsgStage m <= inProgressPairStage p) pip
-			case (wrongstage, sane, pairMsgStage m) of
+			let fromus = maybe False (\p -> remoteSshPubKey (pairMsgData m) == remoteSshPubKey (inProgressPairData p)) pip
-				-- ignore our own messages, and
+			case (wrongstage, fromus, sane, pairMsgStage m) of
-				-- out of order messages
+				(_, True, _, _) -> do
-				(True, _, _) -> go reqs cache sock
+					debug ["ignoring message that looped back"]
-				(_, False, _) -> go reqs cache sock
+					go reqs cache sock
-				(_, _, PairReq) -> if m `elem` reqs
+				(_, _, 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
-				(_, _, PairAck) -> do
+				(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
+				(_,_ , _, PairDone) -> do
 					pairDoneReceived verified pip m
 					go reqs cache sock
 
@@ -75,11 +88,10 @@ pairListenerThread urlrenderer = namedThread "PairListener" $ do
 		verified = verifiedPairMsg m pip
 		sameuuid = pairUUID (inProgressPairData pip) == pairUUID (pairMsgData m)
 		
-	{- Various sanity checks on the content of the message. -}
 	checkSane msg
 		{- Control characters could be used in a
 		 - console poisoning attack. -}
-		| any isControl msg || any (`elem` "\r\n") msg = do
+		| any isControl (filter (/= '\n') (decode_c msg)) = do
 			liftAnnex $ warning
 				"illegal control characters in pairing message; ignoring"
 			return False

Assistant/Threads/SanityChecker.hs

@@ -25,8 +25,10 @@ import Utility.Batch
 import Utility.NotificationBroadcaster
 import Config
 import Utility.HumanTime
+import Git.Repair
 
 import Data.Time.Clock.POSIX
+import qualified Data.Set as S
 
 {- 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
@@ -36,6 +38,21 @@ sanityCheckerStartupThread startupdelay = namedThreadUnchecked "SanityCheckerSta
 	{- 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 (checkIndex S.empty)))
+		( do
+			notice ["corrupt index file found at startup; removing and restaging"]
+			liftAnnex $ inRepo nukeIndex
+			{- 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 there's a startup delay, it's done here. -}
 	liftIO $ maybe noop (threadDelaySeconds . Seconds . fromIntegral . durationSeconds) startupdelay
 

Assistant/Threads/TransferWatcher.hs

@@ -16,6 +16,7 @@ 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. -}
@@ -89,6 +90,11 @@ onDel file = case parseTransferFile file of
 		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

Assistant/Threads/UpgradeWatcher.hs

@@ -0,0 +1,109 @@
+{- 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 hooks (startup mvar)
+  	-- Ignore bogus events generated during the startup scan.
+  	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
+	ua <- liftAnnex Url.getUserAgent
+	liftIO $ withTmpFile "git-annex.tmp" $ \tmpfile h -> do
+		hClose h
+		ifM (Url.downloadQuiet distributionInfoUrl [] [] tmpfile ua)
+			( readish <$> readFileStrict tmpfile
+			, return Nothing
+			)
+
+distributionInfoUrl :: String
+distributionInfoUrl = fromJust Build.SysConfig.upgradelocation ++ ".info"

Assistant/Threads/Watcher.hs

@@ -200,6 +200,9 @@ onAdd matcher file filestatus
 			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.
  -}
@@ -214,7 +217,7 @@ onAddDirect symlinkssupported matcher file fs = do
 				 - really modified, but it might have
 				 - just been deleted and been put back,
 				 - so it symlink is restaged to make sure. -}
-				( ifM (scanComplete <$> getDaemonStatus)
+				( ifM (shouldRestage <$> getDaemonStatus)
 					( do
 						link <- liftAnnex $ inRepo $ gitAnnexLink file key
 						addLink file link (Just key)
@@ -286,7 +289,7 @@ onAddSymlink' linktarget mk isdirect file filestatus = go mk
 	 - links too.)
 	 -}
 	ensurestaged (Just link) daemonstatus
-		| scanComplete daemonstatus = addLink file link mk
+		| shouldRestage daemonstatus = addLink file link mk
 		| otherwise = case filestatus of
 			Just s
 				| not (afterLastDaemonRun (statusChangeTime s) daemonstatus) -> noChange

Assistant/Threads/WebApp.hs

@@ -30,6 +30,7 @@ import Assistant.WebApp.Configurators.Preferences
 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
@@ -52,11 +53,12 @@ webAppThread
 	:: AssistantData
 	-> UrlRenderer
 	-> Bool
+	-> Maybe String
 	-> Maybe HostName
 	-> Maybe (IO Url)
 	-> Maybe (Url -> FilePath -> IO ())
 	-> NamedThread
-webAppThread assistantdata urlrenderer noannex listenhost postfirstrun onstartup = thread $ liftIO $ do
+webAppThread assistantdata urlrenderer noannex cannotrun listenhost postfirstrun onstartup = thread $ liftIO $ do
 #ifdef __ANDROID__
 	when (isJust listenhost) $
 		-- See Utility.WebApp
@@ -68,6 +70,7 @@ webAppThread assistantdata urlrenderer noannex listenhost postfirstrun onstartup
 		<*> getreldir
 		<*> pure staticRoutes
 		<*> pure postfirstrun
+		<*> pure cannotrun
 		<*> pure noannex
 		<*> pure listenhost
 	setUrlRenderer urlrenderer $ yesodRender webapp (pack "")

Assistant/TransferSlots.hs

@@ -5,6 +5,8 @@
  - Licensed under the GNU GPL version 3 or higher.
  -}
 
+{-# LANGUAGE CPP #-}
+
 module Assistant.TransferSlots where
 
 import Assistant.Common
@@ -32,8 +34,10 @@ import qualified Data.Map as M
 import qualified Control.Exception as E
 import Control.Concurrent
 import qualified Control.Concurrent.MSemN as MSemN
-import System.Posix.Signals (signalProcessGroup, sigTERM, sigKILL)
+#ifndef mingw32_HOST_OS
 import System.Posix.Process (getProcessGroupIDOf)
+import System.Posix.Signals (signalProcessGroup, sigTERM, sigKILL)
+#endif
 
 type TransferGenerator = Assistant (Maybe (Transfer, TransferInfo, Transferrer -> Assistant ()))
 
@@ -247,13 +251,18 @@ cancelTransfer pause t = do
 	signalthread tid
 		| pause = throwTo tid PauseTransfer
 		| otherwise = killThread tid
-	{- In order to stop helper processes like rsync,
-	 - kill the whole process group of the process running the transfer. -}
 	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
 		void $ tryIO $ signalProcessGroup sigTERM g
 		threadDelay 50000 -- 0.05 second grace period
 		void $ tryIO $ signalProcessGroup sigKILL g
+#else
+		error "TODO: cancelTransfer not implemented on Windows"
+#endif
 
 {- Start or resume a transfer. -}
 startTransfer :: Transfer -> Assistant ()

Assistant/TransferrerPool.hs

@@ -5,12 +5,17 @@
  - Licensed under the GNU GPL version 3 or higher.
  -}
 
+{-# LANGUAGE CPP #-}
+
 module Assistant.TransferrerPool where
 
 import Assistant.Common
 import Assistant.Types.TransferrerPool
 import Logs.Transfer
+
+#ifndef mingw32_HOST_OS
 import qualified Command.TransferKeys as T
+#endif
 
 import Control.Concurrent.STM
 import System.Process (create_group)
@@ -38,13 +43,18 @@ withTransferrer program pool a = do
  - finish. -}
 performTransfer :: Transferrer -> Transfer -> AssociatedFile -> IO Bool
 performTransfer transferrer t f = catchBoolIO $ do
+#ifndef mingw32_HOST_OS
 	T.sendRequest t f (transferrerWrite transferrer)
 	T.readResponse (transferrerRead transferrer)
+#else
+	error "TODO performTransfer not implemented on Windows"
+#endif
 
 {- Starts a new git-annex transferkeys process, setting up a pipe
  - that will be used to communicate with it. -}
 mkTransferrer :: FilePath -> IO Transferrer
 mkTransferrer program = do
+#ifndef mingw32_HOST_OS
 	(myread, twrite) <- createPipe
 	(tread, mywrite) <- createPipe
 	mapM_ (\fd -> setFdOption fd CloseOnExec True) [myread, mywrite]
@@ -68,6 +78,9 @@ mkTransferrer program = do
 		, transferrerWrite = mywriteh
 		, transferrerHandle = pid
 		}
+#else
+	error "TODO mkTransferrer not implemented on Windows"
+#endif
 
 {- Checks if a Transferrer is still running. If not, makes a new one. -}
 checkTransferrer :: FilePath -> Transferrer -> IO Transferrer

Assistant/Types/Alert.hs

@@ -31,6 +31,7 @@ data AlertName
 	| CloudRepoNeededAlert
 	| SyncAlert
 	| NotFsckedAlert
+	| UpgradeAlert
 	deriving (Eq)
 
 {- The first alert is the new alert, the second is an old alert.
@@ -49,10 +50,10 @@ data Alert = Alert
 	, alertIcon :: Maybe AlertIcon
 	, alertCombiner :: Maybe AlertCombiner
 	, alertName :: Maybe AlertName
-	, alertButton :: Maybe AlertButton
+	, alertButtons :: [AlertButton]
 	}
 
-data AlertIcon = ActivityIcon | SyncIcon | SuccessIcon | ErrorIcon | InfoIcon | TheCloud
+data AlertIcon = ActivityIcon | SyncIcon | SuccessIcon | ErrorIcon | InfoIcon | UpgradeIcon | TheCloud
 
 type AlertMap = M.Map AlertId Alert
 
@@ -73,4 +74,5 @@ data AlertButton = AlertButton
 	{ buttonLabel :: Text
 	, buttonUrl :: Text
 	, buttonAction :: Maybe (AlertId -> IO ())
+	, buttonPrimary :: Bool
 	}

Assistant/Types/DaemonStatus.hs

@@ -14,6 +14,7 @@ import Logs.Transfer
 import Assistant.Types.ThreadName
 import Assistant.Types.NetMessager
 import Assistant.Types.Alert
+import Utility.Url
 
 import Control.Concurrent.STM
 import Control.Concurrent.MVar
@@ -28,6 +29,8 @@ data DaemonStatus = DaemonStatus
 	{ startedThreads :: M.Map ThreadName (Async (), IO ())
 	-- False when the daemon is performing its startup scan
 	, scanComplete :: Bool
+	-- True when all files should be restaged.
+	, forceRestage :: Bool
 	-- Time when a previous process of the daemon was running ok
 	, lastRunning :: Maybe POSIXTime
 	-- True when the daily sanity checker is running
@@ -53,18 +56,25 @@ data DaemonStatus = DaemonStatus
 	, desynced :: S.Set UUID
 	-- Pairing request that is in progress.
 	, pairingInProgress :: Maybe PairingInProgress
-	-- Broadcasts notifications about all changes to the DaemonStatus
+	-- Broadcasts notifications about all changes to the DaemonStatus.
 	, changeNotifier :: NotificationBroadcaster
 	-- Broadcasts notifications when queued or current transfers change.
 	, transferNotifier :: NotificationBroadcaster
-	-- Broadcasts notifications when there's a change to the alerts
+	-- Broadcasts notifications when there's a change to the alerts.
 	, alertNotifier :: NotificationBroadcaster
-	-- Broadcasts notifications when the syncRemotes change
+	-- Broadcasts notifications when the syncRemotes change.
 	, syncRemotesNotifier :: NotificationBroadcaster
-	-- Broadcasts notifications when the scheduleLog changes
+	-- Broadcasts notifications when the scheduleLog changes.
 	, scheduleLogNotifier :: NotificationBroadcaster
 	-- Broadcasts a notification once the startup sanity check has run.
 	, startupSanityCheckNotifier :: NotificationBroadcaster
+	-- Broadcasts notifications when the network is connected.
+	, networkConnectedNotifier :: NotificationBroadcaster
+	-- Broadcasts notifications when a global redirect is needed.
+	, globalRedirNotifier :: NotificationBroadcaster
+	, globalRedirUrl :: Maybe URLString
+	-- Actions to run after a Key is transferred.
+	, transferHook :: M.Map Key (Transfer -> IO ())
 	-- When the XMPP client is connected, this will contain the XMPP
 	-- address.
 	, xmppClientID :: Maybe ClientID
@@ -81,6 +91,7 @@ newDaemonStatus :: IO DaemonStatus
 newDaemonStatus = DaemonStatus
 	<$> pure M.empty
 	<*> pure False
+	<*> pure False
 	<*> pure Nothing
 	<*> pure False
 	<*> pure Nothing
@@ -100,5 +111,9 @@ newDaemonStatus = DaemonStatus
 	<*> newNotificationBroadcaster
 	<*> newNotificationBroadcaster
 	<*> newNotificationBroadcaster
+	<*> newNotificationBroadcaster
+	<*> newNotificationBroadcaster
+	<*> pure Nothing
+	<*> pure M.empty
 	<*> pure Nothing
 	<*> pure M.empty

Assistant/Upgrade.hs

@@ -0,0 +1,316 @@
+{- git-annex assistant upgrading
+ -
+ - Copyright 2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU AGPL version 3 or higher.
+ -}
+
+{-# LANGUAGE CPP #-}
+
+module Assistant.Upgrade where
+
+import Assistant.Common
+import Assistant.Restart
+import qualified Annex
+import Assistant.Alert
+import Assistant.DaemonStatus
+import Utility.Env
+import Types.Distribution
+import Logs.Transfer
+import Logs.Web
+import Logs.Presence
+import Logs.Location
+import Annex.Content
+import qualified Backend
+import qualified Types.Backend
+import qualified Types.Key
+import Assistant.TransferQueue
+import Assistant.TransferSlots
+import Remote (remoteFromUUID)
+import Annex.Path
+import Config.Files
+import Utility.ThreadScheduler
+import Utility.Tmp
+import Utility.UserInfo
+import qualified Utility.Lsof as Lsof
+
+import qualified Data.Map as M
+import Data.Tuple.Utils
+
+{- Upgrade without interaction in the webapp. -}
+unattendedUpgrade :: Assistant ()
+unattendedUpgrade = do
+	prepUpgrade
+	url <- runRestart
+	postUpgrade url
+
+prepUpgrade :: Assistant ()
+prepUpgrade = do
+	void $ addAlert upgradingAlert
+	void $ liftIO $ setEnv upgradedEnv "1" True
+	prepRestart
+
+postUpgrade :: URLString -> Assistant ()
+postUpgrade = postRestart
+
+autoUpgradeEnabled :: Assistant Bool
+autoUpgradeEnabled = liftAnnex $ (==) AutoUpgrade . annexAutoUpgrade <$> Annex.getGitConfig
+
+checkSuccessfulUpgrade :: IO Bool
+checkSuccessfulUpgrade = isJust <$> getEnv upgradedEnv
+
+upgradedEnv :: String
+upgradedEnv = "GIT_ANNEX_UPGRADED"
+
+{- Start downloading the distribution key from the web.
+ - Install a hook that will be run once the download is complete,
+ - and finishes the upgrade.
+ -
+ - Creates the destination directory where the upgrade will be installed
+ - early, in order to check if another upgrade has happened (or is
+ - happending). On failure, the directory is removed.
+ -}
+startDistributionDownload :: GitAnnexDistribution -> Assistant ()
+startDistributionDownload d = go =<< liftIO . newVersionLocation d =<< liftIO oldVersionLocation
+  where
+  	go Nothing = debug ["Skipping redundant upgrade"]
+	go (Just dest) = do
+		liftAnnex $ setUrlPresent k u
+		hook <- asIO1 $ distributionDownloadComplete d dest cleanup
+		modifyDaemonStatus_ $ \s -> s
+			{ transferHook = M.insert k hook (transferHook s) }
+		maybe noop (queueTransfer "upgrade" Next (Just f) t)
+			=<< liftAnnex (remoteFromUUID webUUID)
+		startTransfer t
+	k = distributionKey d
+	u = distributionUrl d
+	f = takeFileName u ++ " (for upgrade)"
+	t = Transfer
+		{ transferDirection = Download
+		, transferUUID = webUUID
+		, transferKey = k
+		}
+	cleanup = liftAnnex $ do
+		removeAnnex k
+		setUrlMissing k u
+		logStatus k InfoMissing
+
+{- Called once the download is done.
+ - Passed an action that can be used to clean up the downloaded file.
+ -
+ - Fsck the key to verify the download.
+ -}
+distributionDownloadComplete :: GitAnnexDistribution -> FilePath -> Assistant () -> Transfer -> Assistant ()
+distributionDownloadComplete d dest cleanup t 
+	| transferDirection t == Download = do
+		debug ["finished downloading git-annex distribution"]
+		maybe (failedupgrade "bad download") go
+			=<< liftAnnex (withObjectLoc k fsckit (getM fsckit))
+	| otherwise = cleanup
+  where
+	k = distributionKey d
+	fsckit f = case Backend.maybeLookupBackendName (Types.Key.keyBackendName k) of
+		Nothing -> return $ Just f
+		Just b -> case Types.Backend.fsckKey b of
+			Nothing -> return $ Just f
+			Just a -> ifM (a k f)
+				( return $ Just f
+				, return Nothing
+				)
+	go f = do
+		ua <- asIO $ upgradeToDistribution dest cleanup f
+		fa <- asIO1 failedupgrade
+		liftIO $ ua `catchNonAsync` (fa . show)
+	failedupgrade msg = do
+		void $ addAlert $ upgradeFailedAlert msg
+		cleanup
+		liftIO $ void $ tryIO $ removeDirectoryRecursive dest
+
+{- The upgrade method varies by OS.
+ -
+ - In general, find where the distribution was installed before,
+ - and unpack the new distribution next to it (in a versioned directory).
+ - Then update the programFile to point to the new version.
+ -}
+upgradeToDistribution :: FilePath -> Assistant () -> FilePath -> Assistant ()
+upgradeToDistribution newdir cleanup distributionfile = do
+	liftIO $ createDirectoryIfMissing True newdir
+	(program, deleteold) <- unpack
+	changeprogram program
+	cleanup
+	prepUpgrade
+	url <- runRestart
+	{- At this point, the new assistant is fully running, so
+	 - it's safe to delete the old version. -}
+	liftIO $ void $ tryIO deleteold
+	postUpgrade url
+  where
+	changeprogram program = liftIO $ do
+		unlessM (boolSystem program [Param "version"]) $
+			error "New git-annex program failed to run! Not using."
+		pf <- programFile
+		liftIO $ writeFile pf program
+	
+#ifdef darwin_HOST_OS
+	{- OS X uses a dmg, so mount it, and copy the contents into place. -}
+	unpack = liftIO $ do
+		olddir <- oldVersionLocation
+		withTmpDirIn (parentDir newdir) "git-annex.upgrade" $ \tmpdir -> do
+			void $ boolSystem "hdiutil"
+				[ Param "attach", File distributionfile
+				, Param "-mountpoint", File tmpdir
+				]
+			void $ boolSystem "cp"
+				[ Param "-R"
+				, File $ tmpdir </> installBase </> "Contents"
+				, File $ newdir
+				]
+			void $ boolSystem "hdiutil"
+				[ Param "eject"
+				, File tmpdir
+				]
+			sanitycheck newdir
+		let deleteold = do
+			deleteFromManifest $ olddir </> "Contents" </> "MacOS"
+			makeorigsymlink olddir
+		return (newdir </> "Contents" </> "MacOS" </> "git-annex", deleteold)
+#else
+	{- Linux uses a tarball (so could other POSIX systems), so
+	 - untar it (into a temp directory) and move the directory
+	 - into place. -}
+	unpack = liftIO $ do
+		olddir <- oldVersionLocation
+		withTmpDirIn (parentDir newdir) "git-annex.upgrade" $ \tmpdir -> do
+			let tarball = tmpdir </> "tar"
+			-- Cannot rely on filename extension, and this also
+			-- avoids problems if tar doesn't support transparent
+			-- decompression.
+			void $ boolSystem "sh"
+				[ Param "-c"
+				, Param $ "zcat < " ++ shellEscape distributionfile ++
+					" > " ++ shellEscape tarball
+				]
+			tarok <- boolSystem "tar"
+				[ Param "xf"
+				, Param tarball
+				, Param "--directory", File tmpdir
+				]
+			unless tarok $
+				error $ "failed to untar " ++ distributionfile
+			sanitycheck $ tmpdir </> installBase
+			installby rename newdir (tmpdir </> installBase)
+		let deleteold = do
+			deleteFromManifest olddir
+			makeorigsymlink olddir
+		return (newdir </> "git-annex", deleteold)
+	installby a dstdir srcdir =
+		mapM_ (\x -> a x (dstdir </> takeFileName x))
+			=<< dirContents srcdir
+#endif
+	sanitycheck dir = 
+		unlessM (doesDirectoryExist dir) $
+			error $ "did not find " ++ dir ++ " in " ++ distributionfile
+	makeorigsymlink olddir = do
+		let origdir = parentDir olddir </> installBase
+		nukeFile origdir
+		createSymbolicLink newdir origdir
+
+{- Finds where the old version was installed. -}
+oldVersionLocation :: IO FilePath
+oldVersionLocation = do
+#ifdef darwin_HOST_OS
+	pdir <- parentDir <$> readProgramFile
+	let dirs = splitDirectories pdir
+	{- It will probably be deep inside a git-annex.app directory. -}
+	let olddir = case findIndex ("git-annex.app" `isPrefixOf`) dirs of
+		Nothing -> pdir
+		Just i -> joinPath (take (i + 1) dirs)
+#else
+	olddir <- parentDir <$> readProgramFile
+#endif
+	when (null olddir) $
+		error $ "Cannot find old distribution bundle; not upgrading."
+	return olddir
+
+{- Finds a place to install the new version.
+ - Generally, put it in the parent directory of where the old version was
+ - installed, and use a version number in the directory name.
+ - If unable to write to there, instead put it in the home directory.
+ -
+ - The directory is created. If it already exists, returns Nothing.
+ -}
+newVersionLocation :: GitAnnexDistribution -> FilePath -> IO (Maybe FilePath)
+newVersionLocation d olddir = 
+	trymkdir newloc $ do
+		home <- myHomeDir
+		trymkdir (home </> s) $
+			return Nothing
+  where
+	s = installBase ++ "." ++ distributionVersion d
+	topdir = parentDir olddir
+	newloc = topdir </> s
+	trymkdir dir fallback =
+		(createDirectory dir >> return (Just dir))
+			`catchIO` const fallback
+
+installBase :: String
+installBase = "git-annex." ++
+#ifdef linux_HOST_OS
+	"linux"
+#else
+#ifdef darwin_HOST_OS
+	"app"
+#else
+	"dir"
+#endif
+#endif
+
+deleteFromManifest :: FilePath -> IO ()
+deleteFromManifest dir = do
+	fs <- map (dir </>) . lines <$> catchDefaultIO "" (readFile manifest)
+	mapM_ nukeFile fs
+	nukeFile manifest
+	removeEmptyRecursive dir
+  where
+	manifest = dir </> "git-annex.MANIFEST"
+
+removeEmptyRecursive :: FilePath -> IO ()
+removeEmptyRecursive dir = do
+	print ("remove", dir)
+	mapM_ removeEmptyRecursive =<< dirContents dir
+	void $ tryIO $ removeDirectory dir
+
+{- This is a file that the UpgradeWatcher can watch for modifications to
+ - detect when git-annex has been upgraded.
+ -}
+upgradeFlagFile :: IO (Maybe FilePath)
+upgradeFlagFile = ifM usingDistribution
+	( Just <$> programFile
+	, programPath
+	)
+
+{- Sanity check to see if an upgrade is complete and the program is ready
+ - to be run. -}
+upgradeSanityCheck :: IO Bool
+upgradeSanityCheck = ifM usingDistribution
+	( doesFileExist =<< programFile
+	, do
+		-- Ensure that the program is present, and has no writers,
+		-- and can be run. This should handle distribution
+		-- upgrades, manual upgrades, etc.
+		v <- programPath
+		case v of
+			Nothing -> return False
+			Just program -> do
+				untilM (doesFileExist program <&&> nowriter program) $
+					threadDelaySeconds (Seconds 60)
+				boolSystem program [Param "version"]
+	)
+  where
+	nowriter f = null
+		. filter (`elem` [Lsof.OpenReadWrite, Lsof.OpenWriteOnly])
+		. map snd3
+		<$> Lsof.query [f]
+
+usingDistribution :: IO Bool
+usingDistribution = isJust <$> getEnv "GIT_ANNEX_STANDLONE_ENV"

Assistant/WebApp/Common.hs

@@ -12,6 +12,7 @@ import Assistant.WebApp as X
 import Assistant.WebApp.Page as X
 import Assistant.WebApp.Form as X
 import Assistant.WebApp.Types as X
+import Assistant.WebApp.RepoId as X
 import Utility.Yesod as X hiding (textField, passwordField, insertBy, replace, joinPath, deleteBy, delete, insert, Key, Option)
 
 import Data.Text as X (Text)

Assistant/WebApp/Configurators/AWS.hs

@@ -23,7 +23,7 @@ import Types.Remote (RemoteConfig)
 import Types.StandardGroups
 import Creds
 import Assistant.Gpg
-import Git.Remote
+import Git.Types (RemoteName)
 
 import qualified Data.Text as T
 import qualified Data.Map as M

Assistant/WebApp/Configurators/Edit.hs

@@ -37,6 +37,9 @@ import Git.Remote
 import Remote.Helper.Encryptable (extractCipher)
 import Types.Crypto
 import Utility.Gpg
+import Annex.UUID
+import Assistant.Ssh
+import Config
 
 import qualified Data.Text as T
 import qualified Data.Map as M
@@ -157,27 +160,30 @@ editRepositoryAForm ishere def = RepoConfig
 		Nothing -> aopt hiddenField "" Nothing
 		Just d -> aopt textField "Associated directory" (Just $ Just d)
 
-getEditRepositoryR :: UUID -> Handler Html
+getEditRepositoryR :: RepoId -> Handler Html
 getEditRepositoryR = postEditRepositoryR
 
-postEditRepositoryR :: UUID -> Handler Html
+postEditRepositoryR :: RepoId -> Handler Html
 postEditRepositoryR = editForm False
 
 getEditNewRepositoryR :: UUID -> Handler Html
 getEditNewRepositoryR = postEditNewRepositoryR
 
 postEditNewRepositoryR :: UUID -> Handler Html
-postEditNewRepositoryR = editForm True
+postEditNewRepositoryR = editForm True . RepoUUID
 
 getEditNewCloudRepositoryR :: UUID -> Handler Html
 getEditNewCloudRepositoryR = postEditNewCloudRepositoryR
 
 postEditNewCloudRepositoryR :: UUID -> Handler Html
-postEditNewCloudRepositoryR uuid = xmppNeeded >> editForm True uuid
+postEditNewCloudRepositoryR uuid = xmppNeeded >> editForm True (RepoUUID uuid)
 
-editForm :: Bool -> UUID -> Handler Html
+editForm :: Bool -> RepoId -> Handler Html
-editForm new uuid = page "Edit repository" (Just Configuration) $ do
+editForm new (RepoUUID uuid) = page "Edit repository" (Just Configuration) $ do
 	mremote <- liftAnnex $ Remote.remoteFromUUID uuid
+	when (mremote == Nothing) $
+		whenM ((/=) uuid <$> liftAnnex getUUID) $
+			error "unknown remote"
 	curr <- liftAnnex $ getRepoConfig uuid mremote
 	liftAnnex $ checkAssociatedDirectory curr mremote
 	((result, form), enctype) <- liftH $
@@ -192,7 +198,13 @@ editForm new uuid = page "Edit repository" (Just Configuration) $ do
 			config <- liftAnnex $ M.lookup uuid <$> readRemoteLog
 			let repoInfo = getRepoInfo mremote config
 			let repoEncryption = getRepoEncryption mremote config
-			$(widgetFile "configurators/editrepository")
+			$(widgetFile "configurators/edit/repository")
+editForm new r@(RepoName _) = page "Edit repository" (Just Configuration) $ do
+	mr <- liftAnnex (repoIdRemote r)
+	let repoInfo = getRepoInfo mr Nothing
+	g <- liftAnnex gitRepo
+	let sshrepo = maybe False (remoteLocationIsSshUrl . flip parseRemoteLocation g . Git.repoLocation . Remote.repo) mr
+	$(widgetFile "configurators/edit/nonannexremote")
 
 {- Makes any directory associated with the repository. -}
 checkAssociatedDirectory :: RepoConfig -> Maybe Remote -> Annex ()
@@ -241,3 +253,17 @@ encrypted using gpg key:
       ^{gpgKeyDisplay k (M.lookup k knownkeys)}
 |]
 getRepoEncryption _ _ = return () -- local repo
+
+getUpgradeRepositoryR  :: RepoId -> Handler ()
+getUpgradeRepositoryR (RepoUUID _) = redirect DashboardR
+getUpgradeRepositoryR r = go =<< liftAnnex (repoIdRemote r)
+  where
+  	go Nothing = redirect DashboardR
+	go (Just rmt) = do
+		liftIO fixSshKeyPair
+		liftAnnex $ setConfig 
+			(remoteConfig (Remote.repo rmt) "ignore")
+			(Git.Config.boolConfig False)
+		liftAssistant $ syncRemote rmt
+		liftAnnex $ void Remote.remoteListRefresh
+		redirect DashboardR

Assistant/WebApp/Configurators/Local.hs

@@ -10,10 +10,10 @@
 module Assistant.WebApp.Configurators.Local where
 
 import Assistant.WebApp.Common
-import Assistant.WebApp.OtherRepos
 import Assistant.WebApp.Gpg
 import Assistant.WebApp.MakeRemote
 import Assistant.Sync
+import Assistant.Restart
 import Init
 import qualified Git
 import qualified Git.Construct
@@ -24,12 +24,13 @@ import Config.Files
 import Utility.FreeDesktop
 #ifdef WITH_CLIBS
 import Utility.Mounts
-#endif
 import Utility.DiskFree
+#endif
 import Utility.DataUnits
 import Utility.Network
 import Remote (prettyUUID)
 import Annex.UUID
+import Annex.Direct
 import Types.StandardGroups
 import Logs.PreferredContent
 import Logs.UUID
@@ -167,7 +168,7 @@ getAndroidCameraRepositoryR =
   where
   	addignore = do
 		liftIO $ unlessM (doesFileExist ".gitignore") $
-			writeFile ".gitignore" ".thumbnails/*"
+			writeFile ".gitignore" ".thumbnails"
 		void $ inRepo $
 			Git.Command.runBool [Param "add", File ".gitignore"]
 
@@ -199,7 +200,7 @@ getCombineRepositoryR :: FilePath -> UUID -> Handler Html
 getCombineRepositoryR newrepopath newrepouuid = do
 	r <- combineRepos newrepopath remotename
 	liftAssistant $ syncRemote r
-	redirect $ EditRepositoryR newrepouuid
+	redirect $ EditRepositoryR $ RepoUUID newrepouuid
   where
 	remotename = takeFileName newrepopath
 

Assistant/WebApp/Configurators/Pairing.hs

@@ -249,6 +249,7 @@ startLocalPairing stage oncancel alert muuid displaysecret secret = do
 		tid <- liftIO myThreadId
 		let selfdestruct = AlertButton
 			{ buttonLabel = "Cancel"
+			, buttonPrimary = True
 			, buttonUrl = urlrender DashboardR
 			, buttonAction = Just $ const $ do
 				oncancel

Assistant/WebApp/Configurators/Preferences.hs

@@ -19,6 +19,8 @@ import Config
 import Config.Files
 import Utility.DataUnits
 import Git.Config
+import Types.Distribution
+import qualified Build.SysConfig
 
 import qualified Data.Text as T
 
@@ -26,6 +28,7 @@ data PrefsForm = PrefsForm
 	{ diskReserve :: Text
 	, numCopies :: Int
 	, autoStart :: Bool
+	, autoUpgrade :: AutoUpgrade
 	, debugEnabled :: Bool
 	}
 
@@ -37,6 +40,8 @@ prefsAForm def = PrefsForm
 		"Number of copies" (Just $ numCopies def)
 	<*> areq (checkBoxField `withNote` autostartnote)
 		"Auto start" (Just $ autoStart def)
+	<*> areq (selectFieldList autoUpgradeChoices)
+		autoUpgradeLabel (Just $ autoUpgrade def)
 	<*> areq (checkBoxField `withNote` debugnote)
 		"Enable debug logging" (Just $ debugEnabled def)
   where
@@ -45,6 +50,16 @@ prefsAForm def = PrefsForm
 	debugnote = [whamlet|<a href="@{LogR}">View Log</a>|]
 	autostartnote = [whamlet|Start the git-annex assistant at boot or on login.|]
 
+	autoUpgradeChoices :: [(Text, AutoUpgrade)]
+	autoUpgradeChoices =
+		[ ("ask me", AskUpgrade)
+		, ("enabled", AutoUpgrade)
+		, ("disabled", NoAutoUpgrade)
+		]
+	autoUpgradeLabel
+		| isJust Build.SysConfig.upgradelocation = "Auto upgrade"
+		| otherwise = "Auto restart on upgrade"
+
 	positiveIntField = check isPositive intField
 	  where
 		isPositive i
@@ -68,12 +83,14 @@ getPrefs = PrefsForm
 	<$> (T.pack . roughSize storageUnits False . annexDiskReserve <$> Annex.getGitConfig)
 	<*> (annexNumCopies <$> Annex.getGitConfig)
 	<*> inAutoStartFile
+	<*> (annexAutoUpgrade <$> Annex.getGitConfig)
 	<*> (annexDebug <$> Annex.getGitConfig)
 
 storePrefs :: PrefsForm -> Annex ()
 storePrefs p = do
 	setConfig (annexConfig "diskreserve") (T.unpack $ diskReserve p)
 	setConfig (annexConfig "numcopies") (show $ numCopies p)
+	setConfig (annexConfig "autoupgrade") (fromAutoUpgrade $ autoUpgrade p)
 	unlessM ((==) <$> pure (autoStart p) <*> inAutoStartFile) $ do
 		here <- fromRepo Git.repoPath
 		liftIO $ if autoStart p

Assistant/WebApp/Configurators/Ssh.hs

@@ -20,7 +20,7 @@ import Types.StandardGroups
 import Utility.UserInfo
 import Utility.Gpg
 import Types.Remote (RemoteConfig)
-import Git.Remote
+import Git.Types (RemoteName)
 import qualified Remote.GCrypt as GCrypt
 import Annex.UUID
 import Logs.UUID

Assistant/WebApp/Configurators/Upgrade.hs

@@ -0,0 +1,48 @@
+{- git-annex assistant webapp upgrade UI
+ -
+ - Copyright 2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU AGPL version 3 or higher.
+ -}
+
+{-# LANGUAGE CPP, QuasiQuotes, TemplateHaskell, OverloadedStrings #-}
+
+module Assistant.WebApp.Configurators.Upgrade where
+
+import Assistant.WebApp.Common
+import Types.Distribution
+import Assistant.Upgrade
+import Assistant.Restart
+import Config
+
+{- On Android, just point the user at the apk file to download.
+ - Installation will be handled by selecting the downloaded file.
+ -
+ - Otherwise, start the upgrade process, which will run fully
+ - noninteractively.
+ - -}
+getConfigStartUpgradeR :: GitAnnexDistribution -> Handler Html
+getConfigStartUpgradeR d = do
+#ifdef ANDROID_SPLICES
+	let url = distributionUrl d
+	page "Upgrade" (Just Configuration) $
+		$(widgetFile "configurators/upgrade/android")
+#else
+	liftAssistant $ startDistributionDownload d
+	redirect DashboardR
+#endif
+
+{- Finish upgrade by starting the new assistant in the same repository this
+ - one is running in, and redirecting to it. -}
+getConfigFinishUpgradeR :: Handler Html
+getConfigFinishUpgradeR = do
+	liftAssistant prepUpgrade
+	url <- liftAssistant runRestart
+	liftAssistant $ postUpgrade url
+	redirect url
+
+getConfigEnableAutomaticUpgradeR :: Handler Html
+getConfigEnableAutomaticUpgradeR = do
+	liftAnnex $ setConfig (annexConfig "autoupgrade")
+		(fromAutoUpgrade AutoUpgrade)
+	redirect DashboardR

Assistant/WebApp/Configurators/WebDAV.hs

@@ -18,7 +18,7 @@ import qualified Remote
 import Types.Remote (RemoteConfig)
 import Types.StandardGroups
 import Logs.Remote
-import Git.Remote
+import Git.Types (RemoteName)
 
 import qualified Data.Map as M
 #endif

Assistant/WebApp/Configurators/XMPP.hs

@@ -43,6 +43,7 @@ xmppNeeded = whenM (isNothing <$> liftAnnex getXMPPCreds) $ do
 			{ buttonLabel = "Configure a Jabber account"
 			, buttonUrl = urlrender XMPPConfigR
 			, buttonAction = Just close
+			, buttonPrimary = True
 			}
 #else
 xmppNeeded = return ()

Assistant/WebApp/Control.hs

@@ -1,6 +1,6 @@
 {- git-annex assistant webapp control
  -
- - Copyright 2012 Joey Hess <joey@kitenet.net>
+ - Copyright 2012, 2013 Joey Hess <joey@kitenet.net>
  -
  - Licensed under the GNU AGPL version 3 or higher.
  -}
@@ -10,15 +10,17 @@
 module Assistant.WebApp.Control where
 
 import Assistant.WebApp.Common
-import Config.Files
-import Utility.LogFile
 import Assistant.DaemonStatus
 import Assistant.Alert
 import Assistant.TransferSlots
+import Assistant.Restart
+import Utility.LogFile
+import Utility.NotificationBroadcaster
 
 import Control.Concurrent
 import System.Posix (getProcessID, signalProcess, sigTERM)
 import qualified Data.Map as M
+import qualified Data.Text as T
 
 getShutdownR :: Handler Html
 getShutdownR = page "Shutdown" Nothing $
@@ -36,26 +38,32 @@ getShutdownConfirmedR = do
 		 - the transfer processes). -}
 		ts <- M.keys . currentTransfers <$> getDaemonStatus
 		mapM_ pauseTransfer ts
-	page "Shutdown" Nothing $ do
+	webapp <- getYesod
+	let url = T.unpack $ yesodRender webapp (T.pack "") NotRunningR []
+	{- Signal any other web browsers. -}
+	liftAssistant $ do
+		modifyDaemonStatus_ $ \status -> status { globalRedirUrl = Just url }
+		liftIO . sendNotification . globalRedirNotifier =<< getDaemonStatus
 	{- Wait 2 seconds before shutting down, to give the web
 	 - page time to load in the browser. -}
 	void $ liftIO $ forkIO $ do
 		threadDelay 2000000
 		signalProcess sigTERM =<< getProcessID
-		$(widgetFile "control/shutdownconfirmed")
+	redirect NotRunningR
+
+{- Use a custom page to avoid putting long polling elements on it that will 
+ - fail and cause the web browser to show an error once the webapp is
+ - truely stopped. -}
+getNotRunningR :: Handler Html
+getNotRunningR = customPage' False Nothing $
+	$(widgetFile "control/notrunning")
 
-{- Quite a hack, and doesn't redirect the browser window. -}
 getRestartR :: Handler Html
-getRestartR = page "Restarting" Nothing $ do
+getRestartR = do
-	void $ liftIO $ forkIO $ do
+	liftAssistant prepRestart
-		threadDelay 2000000
+	url <- liftAssistant runRestart
-		program <- readProgramFile
+	liftAssistant $ postRestart url
-		unlessM (boolSystem "sh" [Param "-c", Param $ restartcommand program]) $
+	redirect url
-			error "restart failed"
-	$(widgetFile "control/restarting")
-  where
-	restartcommand program = program ++ " assistant --stop; exec " ++
-		program ++ " webapp"
 
 getRestartThreadR :: ThreadName -> Handler ()
 getRestartThreadR name = do
@@ -67,5 +75,5 @@ getLogR :: Handler Html
 getLogR = page "Logs" Nothing $ do
 	logfile <- liftAnnex $ fromRepo gitAnnexLogFile
 	logs <- liftIO $ listLogs logfile
-	logcontent <- liftIO $ concat <$> mapM readFile logs
+	logcontent <- liftIO $ concat <$> mapM readFileStrictAnyEncoding logs
 	$(widgetFile "control/log")

Assistant/WebApp/Form.hs

@@ -67,8 +67,7 @@ withExpandableNote :: (Monad m, ToWidget (HandlerSite m) w) => Field m v -> (Str
 withExpandableNote :: Field sub master v -> (String, GWidget sub master ()) -> Field sub master v
 #endif
 withExpandableNote field (toggle, note) = withNote field $ [whamlet|
-<a .btn data-toggle="collapse" data-target="##{ident}">
+<a .btn data-toggle="collapse" data-target="##{ident}">#{toggle}</a>
-  #{toggle}
 <div ##{ident} .collapse>
   ^{note}
 |]

Assistant/WebApp/Gpg.hs

@@ -18,6 +18,7 @@ import qualified Git.Construct
 import qualified Annex.Branch
 import qualified Git.GCrypt
 import qualified Remote.GCrypt as GCrypt
+import Git.Types (RemoteName)
 import Assistant.WebApp.MakeRemote
 import Logs.Remote
 
@@ -63,7 +64,7 @@ withNewSecretKey use = do
  - branch from the gcrypt remote and merges it in, and then looks up
  - the name.
  -}
-getGCryptRemoteName :: UUID -> String -> Annex Git.Remote.RemoteName
+getGCryptRemoteName :: UUID -> String -> Annex RemoteName
 getGCryptRemoteName u repoloc = do
 	tmpremote <- uniqueRemoteName "tmpgcryptremote" 0 <$> gitRepo
 	void $ inRepo $ Git.Command.runBool

Assistant/WebApp/MakeRemote.hs

@@ -17,7 +17,7 @@ import qualified Remote
 import qualified Config
 import Config.Cost
 import Types.StandardGroups
-import Git.Remote
+import Git.Types (RemoteName)
 import Logs.PreferredContent
 import Assistant.MakeRemote
 

Assistant/WebApp/Notifications.hs

@@ -50,7 +50,6 @@ autoUpdate tident geturl ms_delay ms_startdelay = do
 	let startdelay = Aeson.String (T.pack (show ms_startdelay))
 	let ident = Aeson.String tident
 #endif
-	addScript $ StaticR longpolling_js
 	$(widgetFile "notifications/longpolling")
 
 {- Notifier urls are requested by the javascript, to avoid allocation
@@ -82,6 +81,9 @@ getNotifierRepoListR reposelector = notifierUrl route getRepoListBroadcaster
   where
 	route nid = RepoListR nid reposelector
 
+getNotifierGlobalRedirR :: Handler RepPlain
+getNotifierGlobalRedirR = notifierUrl GlobalRedirR getGlobalRedirBroadcaster
+
 getTransferBroadcaster :: Assistant NotificationBroadcaster
 getTransferBroadcaster = transferNotifier <$> getDaemonStatus
 
@@ -93,3 +95,12 @@ getBuddyListBroadcaster =  getBuddyBroadcaster <$> getAssistant buddyList
 
 getRepoListBroadcaster :: Assistant NotificationBroadcaster
 getRepoListBroadcaster =  syncRemotesNotifier <$> getDaemonStatus
+
+getGlobalRedirBroadcaster :: Assistant NotificationBroadcaster
+getGlobalRedirBroadcaster =  globalRedirNotifier <$> getDaemonStatus
+
+getGlobalRedirR :: NotificationId -> Handler RepPlain
+getGlobalRedirR nid = do
+	waitNotifier getGlobalRedirBroadcaster nid
+	maybe (getGlobalRedirR nid) (return . RepPlain . toContent . T.pack)
+		=<< globalRedirUrl <$> liftAssistant getDaemonStatus

Assistant/WebApp/OtherRepos.hs

@@ -12,14 +12,9 @@ module Assistant.WebApp.OtherRepos where
 import Assistant.Common
 import Assistant.WebApp.Types
 import Assistant.WebApp.Page
-import qualified Git.Construct
-import qualified Git.Config
 import Config.Files
-import qualified Utility.Url as Url
 import Utility.Yesod
-
+import Assistant.Restart
-import Control.Concurrent
-import System.Process (cwd)
 
 getRepositorySwitcherR :: Handler Html
 getRepositorySwitcherR = page "Switch repository" Nothing $ do
@@ -35,34 +30,7 @@ listOtherRepos = do
 	names <- mapM relHome gooddirs
 	return $ sort $ zip names gooddirs
 
-{- 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. Once it's running, redirect to it.
- -}
 getSwitchToRepositoryR :: FilePath -> Handler Html
 getSwitchToRepositoryR repo = do
-	liftIO $ startAssistant repo
 	liftIO $ addAutoStartFile repo -- make this the new default repo
-	redirect =<< liftIO geturl
+	redirect =<< liftIO (newAssistantUrl repo)
-  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 (listening url)
-				( return url
-				, delayed $ waiturl urlfile
-				)
-	listening url = catchBoolIO $ fst <$> Url.exists url [] Nothing
-	delayed a = do
-		threadDelay 100000 -- 1/10th of a second
-		a
-
-startAssistant :: FilePath -> IO ()
-startAssistant repo = do
-	program <- readProgramFile
-	void $ forkIO $ void $ createProcess $
-		(proc program ["assistant"]) { cwd = Just repo }

Assistant/WebApp/Page.hs

@@ -50,8 +50,13 @@ page title navbaritem content = customPage navbaritem $ do
 
 {- A custom page, with no title or sidebar set. -}
 customPage :: Maybe NavBarItem -> Widget -> Handler Html
-customPage navbaritem content = do
+customPage = customPage' True
+
+customPage' :: Bool -> Maybe NavBarItem -> Widget -> Handler Html
+customPage' with_longpolling navbaritem content = do
 	webapp <- getYesod
+	case cannotRun webapp of
+		Nothing -> do
 			navbar <- map navdetails <$> selectNavBar
 			pageinfo <- widgetToPageContent $ do
 				addStylesheet $ StaticR css_bootstrap_css
@@ -60,8 +65,11 @@ customPage navbaritem content = do
 				addScript $ StaticR js_bootstrap_dropdown_js
 				addScript $ StaticR js_bootstrap_modal_js
 				addScript $ StaticR js_bootstrap_collapse_js
+				when with_longpolling $
+					addScript $ StaticR longpolling_js
 				$(widgetFile "page")
 			giveUrlRenderer $(Hamlet.hamletFile $ hamletTemplate "bootstrap")
+		Just msg -> error msg
   where
 	navdetails i = (navBarName i, navBarRoute i, Just i == navbaritem)
 

Assistant/WebApp/RepoId.hs

@@ -0,0 +1,40 @@
+{- git-annex assistant webapp RepoId type
+ -
+ - Copyright 2012,2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU AGPL version 3 or higher.
+ -}
+
+module Assistant.WebApp.RepoId where
+
+import Common.Annex
+import Git.Types (RemoteName)
+import qualified Remote
+
+{- Parts of the webapp need to be able to act on repositories that may or
+ - may not have a UUID. -}
+data RepoId
+	= RepoUUID UUID
+	| RepoName RemoteName
+  deriving (Eq, Ord, Show, Read)
+
+mkRepoId :: Remote -> RepoId
+mkRepoId r = case Remote.uuid r of
+	NoUUID -> RepoName (Remote.name r)
+	u -> RepoUUID u
+
+
+describeRepoId :: RepoId -> Annex String
+describeRepoId (RepoUUID u) = Remote.prettyUUID u
+describeRepoId (RepoName n) = return n
+
+repoIdRemote :: RepoId -> Annex (Maybe Remote)
+repoIdRemote (RepoUUID u) = Remote.remoteFromUUID u
+repoIdRemote (RepoName n) = Remote.byNameOnly n
+
+lacksUUID :: RepoId -> Bool
+lacksUUID r = asUUID r == NoUUID
+
+asUUID :: RepoId -> UUID
+asUUID (RepoUUID u) = u
+asUUID _ = NoUUID

Assistant/WebApp/RepoList.hs

@@ -12,7 +12,6 @@ module Assistant.WebApp.RepoList where
 import Assistant.WebApp.Common
 import Assistant.DaemonStatus
 import Assistant.WebApp.Notifications
-import Assistant.Ssh
 import qualified Annex
 import qualified Remote
 import qualified Types.Remote as Remote
@@ -22,20 +21,22 @@ import Logs.Remote
 import Logs.Trust
 import Logs.Group
 import Config
-import Git.Config
 import Git.Remote
 import Assistant.Sync
 import Config.Cost
 import Utility.NotificationBroadcaster
 import qualified Git
-#ifdef WITH_XMPP
-#endif
 
 import qualified Data.Map as M
 import qualified Data.Set as S
 import qualified Data.Text as T
 import Data.Function
 
+type RepoList = [(RepoDesc, RepoId, Actions)]
+
+type RepoDesc = String
+
+{- Actions that can be performed on a repo in the list. -}
 data Actions
 	= DisabledRepoActions
 		{ setupRepoLink :: Route WebApp }
@@ -50,21 +51,21 @@ data Actions
 	| UnwantedRepoActions
 		{ setupRepoLink :: Route WebApp }
 
-mkSyncingRepoActions :: UUID -> Actions
+mkSyncingRepoActions :: RepoId -> Actions
-mkSyncingRepoActions u = SyncingRepoActions
+mkSyncingRepoActions repoid = SyncingRepoActions
-	{ setupRepoLink = EditRepositoryR u
+	{ setupRepoLink = EditRepositoryR repoid
-	, syncToggleLink = DisableSyncR u
+	, syncToggleLink = DisableSyncR repoid
 	}
 
-mkNotSyncingRepoActions :: UUID -> Actions
+mkNotSyncingRepoActions :: RepoId -> Actions
-mkNotSyncingRepoActions u = NotSyncingRepoActions
+mkNotSyncingRepoActions repoid = NotSyncingRepoActions
-	{ setupRepoLink = EditRepositoryR u
+	{ setupRepoLink = EditRepositoryR repoid
-	, syncToggleLink = EnableSyncR u
+	, syncToggleLink = EnableSyncR repoid
 	}
 
-mkUnwantedRepoActions :: UUID -> Actions
+mkUnwantedRepoActions :: RepoId -> Actions
-mkUnwantedRepoActions u = UnwantedRepoActions
+mkUnwantedRepoActions repoid = UnwantedRepoActions
-	{ setupRepoLink = EditRepositoryR u
+	{ setupRepoLink = EditRepositoryR repoid
 	}
 
 needsEnabled :: Actions -> Bool
@@ -122,9 +123,6 @@ repoListDisplay reposelector = do
 	$(widgetFile "repolist")
   where
 	ident = "repolist"
-	unfinished uuid = uuid == NoUUID
-
-type RepoList = [(String, UUID, Actions)]
 
 {- A list of known repositories, with actions that can be taken on them. -}
 repoList :: RepoSelector -> Handler RepoList
@@ -133,27 +131,27 @@ repoList reposelector
 	| otherwise = list =<< (++) <$> configured <*> unconfigured
   where
 	configured = do
-		syncing <- S.fromList . map Remote.uuid . syncRemotes
+		syncremotes <- syncRemotes <$> liftAssistant getDaemonStatus
-			<$> liftAssistant getDaemonStatus
+		let syncing = S.fromList $ map mkRepoId syncremotes
 		liftAnnex $ do
 			unwanted <- S.fromList
-				<$> filterM inUnwantedGroup (S.toList syncing)
+				<$> filterM inUnwantedGroup (map Remote.uuid syncremotes)
 			rs <- filter selectedrepo . concat . Remote.byCost
 				<$> Remote.remoteList
-			let us = map Remote.uuid rs
+			let l = flip map (map mkRepoId rs) $ \r -> case r of
-			let maker u
+				(RepoUUID u)
-				| u `S.member` unwanted = mkUnwantedRepoActions u
+					| u `S.member` unwanted -> (r, mkUnwantedRepoActions r)
-				| u `S.member` syncing = mkSyncingRepoActions u
+				_
-				| otherwise = mkNotSyncingRepoActions u
+					| r `S.member` syncing -> (r, mkSyncingRepoActions r)
-			let l = zip us $ map (maker . Remote.uuid) rs
+					| otherwise -> (r, mkNotSyncingRepoActions r)
 			if includeHere reposelector
 				then do
-					u <- getUUID
+					r <- RepoUUID <$> getUUID
 					autocommit <- annexAutoCommit <$> Annex.getGitConfig
 					let hereactions = if autocommit
-						then mkSyncingRepoActions u
+						then mkSyncingRepoActions r
-						else mkNotSyncingRepoActions u
+						else mkNotSyncingRepoActions r
-					let here = (u, hereactions)
+					let here = (r, hereactions)
 					return $ here : l
 				else return l
 	unconfigured = liftAnnex $ do
@@ -164,7 +162,9 @@ repoList reposelector
 			<$> trustExclude DeadTrusted (M.keys m)
 	selectedrepo r
 		| Remote.readonly r = False
-		| onlyCloud reposelector = Git.repoIsUrl (Remote.repo r) && not (isXMPPRemote r)
+		| onlyCloud reposelector = Git.repoIsUrl (Remote.repo r)
+			&& Remote.uuid r /= NoUUID 
+			&& not (isXMPPRemote r)
 		| otherwise = True
 	selectedremote Nothing = False
 	selectedremote (Just (iscloud, _))
@@ -190,23 +190,23 @@ repoList reposelector
 		_ -> Nothing
 	  where
 	  	getconfig k = M.lookup k =<< M.lookup u m
-		val iscloud r = Just (iscloud, (u, DisabledRepoActions $ r u))
+		val iscloud r = Just (iscloud, (RepoUUID u, DisabledRepoActions $ r u))
-	list l = liftAnnex $ do
+	list l = liftAnnex $
-		let l' = nubBy ((==) `on` fst) l
+		forM (nubBy ((==) `on` fst) l) $ \(repoid, actions) ->
-		l'' <- zip
+			(,,)
-			<$> Remote.prettyListUUIDs (map fst l')
+				<$> describeRepoId repoid
-			<*> pure l'
+				<*> pure repoid
-		return $ map (\(name, (uuid, actions)) -> (name, uuid, actions)) l''
+				<*> pure actions
 
-getEnableSyncR :: UUID -> Handler ()
+getEnableSyncR :: RepoId -> Handler ()
 getEnableSyncR = flipSync True
 
-getDisableSyncR :: UUID -> Handler ()
+getDisableSyncR :: RepoId -> Handler ()
 getDisableSyncR = flipSync False
 
-flipSync :: Bool -> UUID -> Handler ()
+flipSync :: Bool -> RepoId -> Handler ()
-flipSync enable uuid = do
+flipSync enable repoid = do
-	mremote <- liftAnnex $ Remote.remoteFromUUID uuid
+	mremote <- liftAnnex $ repoIdRemote repoid
 	liftAssistant $ changeSyncable mremote enable
 	redirectBack
 
@@ -238,29 +238,3 @@ reorderCosts remote rs = zip rs'' (insertCostAfter costs i)
 	costs = map Remote.cost rs'
 	rs'' = (\(x, y) -> x ++ [remote] ++ y) $ splitAt (i + 1) rs'
 
-{- Checks to see if any repositories with NoUUID have annex-ignore set.
- - That could happen if there's a problem contacting a ssh remote
- - soon after it was added. -}
-getCheckUnfinishedRepositoriesR :: Handler Html
-getCheckUnfinishedRepositoriesR = page "Unfinished repositories" (Just Configuration) $ do
-	stalled <- liftAnnex findStalled
-	$(widgetFile "configurators/checkunfinished")
-
-findStalled :: Annex [Remote]
-findStalled = filter isstalled <$> remoteListRefresh
-  where
-  	isstalled r = Remote.uuid r == NoUUID
-		&& remoteAnnexIgnore (Remote.gitconfig r)
-
-getRetryUnfinishedRepositoriesR :: Handler ()
-getRetryUnfinishedRepositoriesR = do
-	liftAssistant $ mapM_ unstall =<< liftAnnex findStalled
-	redirect DashboardR
-  where
-	unstall r = do
-		liftIO fixSshKeyPair
-		liftAnnex $ setConfig 
-			(remoteConfig (Remote.repo r) "ignore")
-			(boolConfig False)
-		syncRemote r
-		liftAnnex $ void remoteListRefresh

Assistant/WebApp/SideBar.hs

@@ -50,6 +50,7 @@ sideBarDisplay = do
 		let message = renderAlertMessage alert
 		let messagelines = T.lines message
 		let multiline = length messagelines > 1
+		let buttons = zip (alertButtons alert) [1..]
 		$(widgetFile "sidebar/alert")
 
 {- Called by client to get a sidebar display.
@@ -79,16 +80,20 @@ getCloseAlert :: AlertId -> Handler ()
 getCloseAlert = liftAssistant . removeAlert
 
 {- When an alert with a button is clicked on, the button takes us here. -}
-getClickAlert :: AlertId -> Handler ()
+getClickAlert :: AlertId -> Int -> Handler ()
-getClickAlert i = do
+getClickAlert i bnum = do
 	m <- alertMap <$> liftAssistant getDaemonStatus
 	case M.lookup i m of
-		Just (Alert { alertButton = Just b }) -> do
+		Just (Alert { alertButtons = bs })
-			{- Spawn a thread to run the action while redirecting. -}
+			| length bs >= bnum -> do
+				let b = bs !! (bnum - 1)
+				{- Spawn a thread to run the action
+				 - while redirecting. -}
 				case buttonAction b of
 					Nothing -> noop
 					Just a -> liftIO $ void $ forkIO $ a i
 				redirect $ buttonUrl b
+			| otherwise -> redirectBack
 		_ -> redirectBack
 
 htmlIcon :: AlertIcon -> Widget
@@ -97,6 +102,7 @@ htmlIcon SyncIcon = [whamlet|<img src="@{StaticR syncicon_gif}" alt="">|]
 htmlIcon InfoIcon = bootstrapIcon "info-sign"
 htmlIcon SuccessIcon = bootstrapIcon "ok"
 htmlIcon ErrorIcon = bootstrapIcon "exclamation-sign"
+htmlIcon UpgradeIcon = bootstrapIcon "arrow-up"
 -- utf-8 umbrella (utf-8 cloud looks too stormy)
 htmlIcon TheCloud = [whamlet|&#9730;|]
 

Assistant/WebApp/Types.hs

@@ -24,6 +24,8 @@ import Logs.Transfer
 import Utility.Gpg (KeyId)
 import Build.SysConfig (packageversion)
 import Types.ScheduledActivity
+import Assistant.WebApp.RepoId
+import Types.Distribution
 
 import Yesod.Static
 import Text.Hamlet
@@ -43,6 +45,7 @@ data WebApp = WebApp
 	, relDir :: Maybe FilePath
 	, getStatic :: Static
 	, postFirstRun :: Maybe (IO String)
+	, cannotRun :: Maybe String
 	, noAnnex :: Bool
 	, listenHost ::Maybe HostName
 	}
@@ -161,6 +164,10 @@ data RemovableDrive = RemovableDrive
 data RepoKey = RepoKey KeyId | NoRepoKey
 	deriving (Read, Show, Eq, Ord)
 
+instance PathPiece Bool where
+	toPathPiece = pack . show
+	fromPathPiece = readish . unpack
+
 instance PathPiece RemovableDrive where
 	toPathPiece = pack . show
 	fromPathPiece = readish . unpack
@@ -216,3 +223,11 @@ instance PathPiece ThreadName where
 instance PathPiece ScheduledActivity where
 	toPathPiece = pack . show
 	fromPathPiece = readish . unpack
+
+instance PathPiece RepoId where
+	toPathPiece = pack . show
+	fromPathPiece = readish . unpack
+
+instance PathPiece GitAnnexDistribution where
+	toPathPiece = pack . show
+	fromPathPiece = readish . unpack

Assistant/WebApp/routes

@@ -9,6 +9,7 @@
 
 /shutdown ShutdownR GET
 /shutdown/confirm ShutdownConfirmedR GET
+/shutdown/complete NotRunningR GET
 /restart RestartR GET
 /restart/thread/#ThreadName RestartThreadR GET
 /log LogR GET
@@ -21,6 +22,9 @@
 /config/xmpp/needcloudrepo/#UUID NeedCloudRepoR GET
 /config/fsck ConfigFsckR GET POST
 /config/fsck/preferences ConfigFsckPreferencesR POST
+/config/upgrade/start/#GitAnnexDistribution ConfigStartUpgradeR GET
+/config/upgrade/finish ConfigFinishUpgradeR GET
+/config/upgrade/automatically ConfigEnableAutomaticUpgradeR GET
 
 /config/addrepository AddRepositoryR GET
 /config/repository/new NewRepositoryR GET POST
@@ -29,13 +33,12 @@
 /config/repository/switcher RepositorySwitcherR GET
 /config/repository/switchto/#FilePath SwitchToRepositoryR GET
 /config/repository/combine/#FilePath/#UUID CombineRepositoryR GET
-/config/repository/edit/#UUID EditRepositoryR GET POST
+/config/repository/edit/#RepoId EditRepositoryR GET POST
 /config/repository/edit/new/#UUID EditNewRepositoryR GET POST
 /config/repository/edit/new/cloud/#UUID EditNewCloudRepositoryR GET POST
-/config/repository/sync/disable/#UUID DisableSyncR GET
+/config/repository/sync/disable/#RepoId DisableSyncR GET
-/config/repository/sync/enable/#UUID EnableSyncR GET
+/config/repository/sync/enable/#RepoId EnableSyncR GET
-/config/repository/unfinished/check CheckUnfinishedRepositoriesR GET
+/config/repository/upgrade/#RepoId UpgradeRepositoryR GET
-/config/repository/unfinished/retry RetryUnfinishedRepositoriesR GET
 
 /config/repository/add/drive AddDriveR GET POST
 /config/repository/add/drive/confirm/#RemovableDrive ConfirmAddDriveR GET
@@ -101,8 +104,11 @@
 /repolist/#NotificationId/#RepoSelector RepoListR GET
 /notifier/repolist/#RepoSelector NotifierRepoListR GET
 
+/globalredir/#NotificationId GlobalRedirR GET
+/notifier/globalredir NotifierGlobalRedirR GET
+
 /alert/close/#AlertId CloseAlert GET
-/alert/click/#AlertId ClickAlert GET
+/alert/click/#AlertId/#Int ClickAlert GET
 /filebrowser FileBrowserR GET POST
 
 /transfer/pause/#Transfer PauseTransferR GET POST

Assistant/XMPP.hs

@@ -21,7 +21,7 @@ import qualified Data.Map as M
 import Data.ByteString (ByteString)
 import qualified Data.ByteString as B
 import Data.XML.Types
-import qualified Codec.Binary.Base64 as B64
+import qualified "dataenc" Codec.Binary.Base64 as B64
 
 {- Name of the git-annex tag, in our own XML namespace.
  - (Not using a namespace URL to avoid unnecessary bloat.) -}

Build/BundledPrograms.hs

@@ -30,6 +30,7 @@ bundledPrograms = catMaybes
 #endif
 	, Just "rsync"
 	, Just "ssh"
+	, Just "ssh-keygen"
 #ifndef mingw32_HOST_OS
 	, Just "sh"
 #endif
@@ -44,6 +45,11 @@ bundledPrograms = catMaybes
 	, SysConfig.sha512
 	, SysConfig.sha224
 	, SysConfig.sha384
+#ifdef linux_HOST_OS
+	-- used to unpack the tarball when upgrading
+	, Just "gunzip"
+	, Just "tar"
+#endif
 	-- nice and ionice are not included in the bundle; we rely on the
 	-- system's own version, which may better match its kernel
 	]

Build/Configure.hs

@@ -7,7 +7,7 @@ import Data.List
 import System.Process
 import Control.Applicative
 import System.FilePath
-import System.Environment
+import System.Environment (getArgs)
 import Data.Maybe
 import Control.Monad.IfElse
 import Data.Char
@@ -17,11 +17,13 @@ import Build.Version
 import Utility.SafeCommand
 import Utility.Monad
 import Utility.ExternalSHA
+import Utility.Env
 import qualified Git.Version
 
 tests :: [TestCase]
 tests =
 	[ TestCase "version" getVersion
+	, TestCase "UPGRADE_LOCATION" getUpgradeLocation
 	, TestCase "git" $ requireCmd "git" "git --version >/dev/null"
 	, TestCase "git version" getGitVersion
 	, testCp "cp_a" "-a"
@@ -33,6 +35,7 @@ tests =
 	, TestCase "wget" $ testCmd "wget" "wget --version >/dev/null"
 	, TestCase "bup" $ testCmd "bup" "bup --version >/dev/null"
 	, TestCase "quvi" $ testCmd "quvi" "quvi --version >/dev/null"
+	, TestCase "newquvi" $ testCmd "newquvi" "quvi info >/dev/null"
 	, TestCase "nice" $ testCmd "nice" "nice true >/dev/null"
 	, TestCase "ionice" $ testCmd "ionice" "ionice -c3 true >/dev/null"
 	, TestCase "gpg" $ maybeSelectCmd "gpg"
@@ -90,6 +93,11 @@ testCp k option = TestCase cmd $ testCmd k cmdline
 	cmd = "cp " ++ option
 	cmdline = cmd ++ " " ++ testFile ++ " " ++ testFile ++ ".new"
 
+getUpgradeLocation :: Test
+getUpgradeLocation = do
+	e <- getEnv "UPGRADE_LOCATION"
+	return $ Config "upgradelocation" $ MaybeStringConfig e
+
 getGitVersion :: Test
 getGitVersion = Config "gitversion" . StringConfig . show
 	<$> Git.Version.installed
@@ -130,4 +138,3 @@ androidConfig c = overrides ++ filter (not . overridden) c
 		]
 	overridden (Config k _) = k `elem` overridekeys
 	overridekeys = map (\(Config k _) -> k) overrides
-

Build/DistributionUpdate.hs

@@ -0,0 +1,64 @@
+{- Builds distributon info files for each git-annex release in a directory
+ - tree, which must itself be part of a git-annex repository. Only files
+ - that are present have their info file created. -}
+
+import Common.Annex
+import Types.Distribution
+import Build.Version
+import Utility.UserInfo
+import Utility.Path
+import qualified Git.Construct
+import qualified Annex
+import Annex.Content
+import Backend
+import Git.Command
+
+import Data.Time.Clock
+
+main = do
+	state <- Annex.new =<< Git.Construct.fromPath =<< getRepoDir
+	Annex.eval state makeinfos
+
+makeinfos :: Annex ()
+makeinfos = do
+	basedir <- liftIO getRepoDir
+	version <- liftIO getChangelogVersion
+	now <- liftIO getCurrentTime
+	liftIO $ putStrLn $ "building info files for version " ++ version ++ " in " ++ basedir
+	fs <- liftIO $ dirContentsRecursiveSkipping (== "info") (basedir </> "git-annex")
+	forM_ fs $ \f -> do
+		v <- lookupFile f
+		case v of
+			Nothing -> noop
+			Just (k, _b) -> whenM (inAnnex k) $ do
+				liftIO $ putStrLn f
+				let infofile = f ++ ".info"
+				liftIO $ writeFile infofile $ show $ GitAnnexDistribution
+					{ distributionUrl = mkUrl basedir f
+					, distributionKey = k
+					, distributionVersion = version
+					, distributionReleasedate = now
+					, distributionUrgentUpgrade = Nothing
+					}
+				void $ inRepo $ runBool [Param "add", Param infofile]
+	void $ inRepo $ runBool 
+		[ Param "commit"
+		, Param "-m"
+		, Param $ "publishing git-annex " ++ version
+		]
+	void $ inRepo $ runBool
+		[ Param "annex"
+		, Params "move --to website"
+		]
+	void $ inRepo $ runBool
+		[ Param "annex"
+		, Params "sync"
+		]
+
+getRepoDir :: IO FilePath
+getRepoDir = do
+	home <- liftIO myHomeDir
+	return $ home </> "lib" </> "downloads"
+
+mkUrl :: FilePath -> FilePath -> String
+mkUrl basedir f = "https://downloads.kitenet.net/" ++ relPathDirToFile basedir f

Build/EvilSplicer.hs

@@ -584,7 +584,7 @@ text_builder_hack = replace "Data.Text.Lazy.Builder.Internal.fromText" "Data.Tex
 parsecAndReplace :: Parser String -> String -> String
 parsecAndReplace p s = case parse find "" s of
 	Left e -> s
-	Right l -> concatMap (either (\c -> [c]) id) l
+	Right l -> concatMap (either return id) l
   where
   	find :: Parser [Either Char String]
 	find = many $ try (Right <$> p) <|> (Left <$> anyChar)

Build/OSXMkLibs.hs

@@ -144,7 +144,7 @@ getLibName lib libmap = case M.lookup lib libmap of
 	Just n -> (n, libmap)
 	Nothing -> (nextfreename, M.insert lib nextfreename libmap)
   where
-	names = map (\c -> [c]) ['A' .. 'Z'] ++
+	names = map pure ['A' .. 'Z'] ++
 		[[n, l] | n <- ['0' .. '9'], l <- ['A' .. 'Z']]
 	used = S.fromList $ M.elems libmap
 	nextfreename = fromMaybe (error "ran out of short library names!") $ 

BuildFlags.hs

@@ -59,5 +59,8 @@ buildFlags = filter (not . null)
 #endif
 #ifdef WITH_CRYPTOHASH
 	, "CryptoHash"
+#endif
+#ifdef WITH_EKG
+	, "EKG"
 #endif
 	]

Command/Add.hs

@@ -23,10 +23,11 @@ import Annex.Perms
 import Annex.Link
 import qualified Annex
 import qualified Annex.Queue
+#ifdef WITH_CLIBS
 #ifndef __ANDROID__
 import Utility.Touch
 #endif
-import Utility.FileMode
+#endif
 import Config
 import Utility.InodeCache
 import Annex.FileMatcher
@@ -86,11 +87,6 @@ start file = ifAnnexed file addpresent add
  - So a KeySource is returned. Its inodeCache can be used to detect any
  - changes that might be made to the file after it was locked down.
  -
- - In indirect mode, the write bit is removed from the file as part of lock
- - down to guard against further writes, and because objects in the annex
- - have their write bit disabled anyway. This is not done in direct mode,
- - because files there need to remain writable at all times.
- -
  - When possible, the file is hard linked to a temp directory. This guards
  - against some changes, like deletion or overwrite of the file, and
  - allows lsof checks to be done more efficiently when adding a lot of files.
@@ -103,16 +99,28 @@ lockDown file = ifM crippledFileSystem
 	, do
 		tmp <- fromRepo gitAnnexTmpDir
 		createAnnexDirectory tmp
+		eitherToMaybe <$> tryAnnexIO (go tmp)
+	)
+  where
+	{- In indirect mode, the write bit is removed from the file as part
+	 - of lock down to guard against further writes, and because objects
+	 - in the annex have their write bit disabled anyway.
+	 -
+	 - Freezing the content early also lets us fail early when
+	 - someone else owns the file.
+	 -
+	 - This is not done in direct mode, because files there need to
+	 - remain writable at all times.
+	-}
+  	go tmp = do
 		unlessM isDirect $
-			void $ liftIO $ tryIO $ preventWrite file
+			freezeContent file
-		liftIO $ catchMaybeIO $ do
+		liftIO $ do
 			(tmpfile, h) <- openTempFile tmp $
 				relatedTemplate $ takeFileName file
 			hClose h
 			nukeFile tmpfile
 			withhardlink tmpfile `catchIO` const nohardlink
-	)
-  where
   	nohardlink = do
 		cache <- genInodeCache file
 		return KeySource
@@ -205,12 +213,14 @@ link file key mcache = flip catchAnnex (undo file key) $ do
 	l <- inRepo $ gitAnnexLink file key
 	replaceFile file $ makeAnnexLink l
 
+#ifdef WITH_CLIBS
 #ifndef __ANDROID__
 	-- touch symlink to have same time as the original file,
 	-- as provided in the InodeCache
 	case mcache of
 		Just c -> liftIO $ touch file (TimeSpec $ inodeCacheToMtime c) False
 		Nothing -> noop
+#endif
 #endif
 
 	return l

Command/Fix.hs

@@ -14,9 +14,11 @@ import System.PosixCompat.Files
 import Common.Annex
 import Command
 import qualified Annex.Queue
+#ifdef WITH_CLIBS
 #ifndef __ANDROID__
 import Utility.Touch
 #endif
+#endif
 
 def :: [Command]
 def = [notDirect $ noCommit $ command "fix" paramPaths seek
@@ -36,16 +38,20 @@ start file (key, _) = do
 perform :: FilePath -> FilePath -> CommandPerform
 perform file link = do
 	liftIO $ do
+#ifdef WITH_CLIBS
 #ifndef __ANDROID__
 		-- preserve mtime of symlink
 		mtime <- catchMaybeIO $ TimeSpec . modificationTime
 			<$> getSymbolicLinkStatus file
+#endif
 #endif
 		createDirectoryIfMissing True (parentDir file)
 		removeFile file
 		createSymbolicLink link file
+#ifdef WITH_CLIBS
 #ifndef __ANDROID__
 		maybe noop (\t -> touch file t False) mtime
+#endif
 #endif
 	next $ cleanup file
 

Command/Fsck.hs

@@ -218,9 +218,10 @@ verifyLocationLog key desc = do
 	
 	{- Since we're checking that a key's file is present, throw
 	 - in a permission fixup here too. -}
-	when (present && not direct) $ do
 	file <- calcRepo $ gitAnnexLocation key
+	when (present && not direct) $
 		freezeContent file
+	whenM (liftIO $ doesDirectoryExist $ parentDir file) $
 		freezeContentDir file
 
 	{- In direct mode, modified files will show up as not present,

Command/GCryptSetup.hs

@@ -23,13 +23,17 @@ seek = [withStrings start]
 
 start :: String -> CommandStart
 start gcryptid = next $ next $ do
-	g <- gitRepo
 	u <- getUUID
+	when (u /= NoUUID) $
+		error "gcryptsetup refusing to run; this repository already has a git-annex uuid!"
+	
+	g <- gitRepo
 	gu <- Remote.GCrypt.getGCryptUUID True g
-	if u == NoUUID && gu == Nothing
+	let newgu = genUUIDInNameSpace gCryptNameSpace gcryptid
+	if gu == Nothing || gu == Just newgu
 		then if Git.repoIsLocalBare g
 			then do
 				void $ Remote.GCrypt.setupRepo gcryptid g
 				return True
 			else error "cannot use gcrypt in a non-bare repository"
-		else error "gcryptsetup permission denied"
+		else error "gcryptsetup uuid mismatch"

Command/ImportFeed.hs

@@ -106,7 +106,7 @@ downloadFeed url = do
 	liftIO $ withTmpFile "feed" $ \f h -> do
 		fileEncoding h
 		ifM (Url.download url [] [] f ua)
-			( liftIO $ parseFeedString <$> hGetContentsStrict h
+			( parseFeedString <$> hGetContentsStrict h
 			, return Nothing
 			)
 

Command/Indirect.hs

@@ -20,9 +20,9 @@ import Config
 import qualified Annex
 import Annex.Direct
 import Annex.Content
+import Annex.Content.Direct
 import Annex.CatFile
 import Annex.Version
-import Annex.Perms
 import Annex.Exception
 import Init
 import qualified Command.Add
@@ -77,7 +77,8 @@ perform = do
 			Just s
 				| isSymbolicLink s -> void $ flip whenAnnexed f $
 					\_ (k, _) -> do
-						cleandirect k
+						removeInodeCache k
+						removeAssociatedFiles k
 						return Nothing
 				| otherwise -> 
 					maybe noop (fromdirect f)
@@ -87,8 +88,8 @@ perform = do
 
 	fromdirect f k = do
 		showStart "indirect" f
-		thawContentDir =<< calcRepo (gitAnnexLocation k)
+		removeInodeCache k
-		cleandirect k -- clean before content directory gets frozen
+		removeAssociatedFiles k
 		whenM (liftIO $ not . isSymbolicLink <$> getSymbolicLinkStatus f) $ do
 			v <-tryAnnexIO (moveAnnex k f)
 			case v of
@@ -104,10 +105,6 @@ perform = do
 		warning $ show e
 		warning "leaving this file as-is; correct this problem and run git annex add on it"
 	
-	cleandirect k = do
-		liftIO . nukeFile =<< calcRepo (gitAnnexInodeCache k)
-		liftIO . nukeFile =<< calcRepo (gitAnnexMapping k)
-	
 cleanup :: CommandCleanup
 cleanup = do
 	setVersion defaultVersion

Command/Info.hs

@@ -0,0 +1,384 @@
+{- git-annex command
+ -
+ - Copyright 2011 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE BangPatterns #-}
+
+module Command.Info where
+
+import "mtl" Control.Monad.State.Strict
+import qualified Data.Map as M
+import Text.JSON
+import Data.Tuple
+import Data.Ord
+import System.PosixCompat.Files
+
+import Common.Annex
+import qualified Remote
+import qualified Command.Unused
+import qualified Git
+import qualified Annex
+import Command
+import Utility.DataUnits
+import Utility.DiskFree
+import Annex.Content
+import Types.Key
+import Logs.UUID
+import Logs.Trust
+import Remote
+import Config
+import Utility.Percentage
+import Logs.Transfer
+import Types.TrustLevel
+import Types.FileMatcher
+import qualified Limit
+
+-- a named computation that produces a statistic
+type Stat = StatState (Maybe (String, StatState String))
+
+-- data about a set of keys
+data KeyData = KeyData
+	{ countKeys :: Integer
+	, sizeKeys :: Integer
+	, unknownSizeKeys :: Integer
+	, backendsKeys :: M.Map String Integer
+	}
+
+data NumCopiesStats = NumCopiesStats
+	{ numCopiesVarianceMap :: M.Map Variance Integer
+	}
+
+newtype Variance = Variance Int
+	deriving (Eq, Ord)
+
+instance Show Variance where
+	show (Variance n)
+		| n >= 0 = "numcopies +" ++ show n
+		| otherwise = "numcopies " ++ show n
+
+-- cached info that multiple Stats use
+data StatInfo = StatInfo
+	{ presentData :: Maybe KeyData
+	, referencedData :: Maybe KeyData
+	, numCopiesStats :: Maybe NumCopiesStats
+	}
+
+-- a state monad for running Stats in
+type StatState = StateT StatInfo Annex
+
+def :: [Command]
+def = [noCommit $ command "info" paramPaths seek
+	SectionQuery "shows general information about the annex"]
+
+seek :: [CommandSeek]
+seek = [withWords start]
+
+start :: [FilePath] -> CommandStart
+start [] = do
+	globalInfo
+	stop
+start ps = do
+	mapM_ localInfo =<< filterM isdir ps
+	stop
+  where
+	isdir = liftIO . catchBoolIO . (isDirectory <$$> getFileStatus)
+
+globalInfo :: Annex ()
+globalInfo = do
+	stats <- selStats global_fast_stats global_slow_stats
+	showCustom "info" $ do
+		evalStateT (mapM_ showStat stats) (StatInfo Nothing Nothing Nothing)
+		return True
+
+localInfo :: FilePath -> Annex ()
+localInfo dir = showCustom (unwords ["info", dir]) $ do
+	stats <- selStats (tostats local_fast_stats) (tostats local_slow_stats)
+	evalStateT (mapM_ showStat stats) =<< getLocalStatInfo dir
+	return True
+  where
+  	tostats = map (\s -> s dir)
+
+selStats :: [Stat] -> [Stat] -> Annex [Stat]
+selStats fast_stats slow_stats = do
+	fast <- Annex.getState Annex.fast
+	return $ if fast
+		then fast_stats
+		else fast_stats ++ slow_stats
+
+{- Order is significant. Less expensive operations, and operations
+ - that share data go together.
+ -}
+global_fast_stats :: [Stat]
+global_fast_stats = 
+	[ repository_mode
+	, remote_list Trusted
+	, remote_list SemiTrusted
+	, remote_list UnTrusted
+	, transfer_list
+	, disk_size
+	]
+global_slow_stats :: [Stat]
+global_slow_stats = 
+	[ tmp_size
+	, bad_data_size
+	, local_annex_keys
+	, local_annex_size
+	, known_annex_files
+	, known_annex_size
+	, bloom_info
+	, backend_usage
+	]
+local_fast_stats :: [FilePath -> Stat]
+local_fast_stats =
+	[ local_dir
+	, const local_annex_keys
+	, const local_annex_size
+	, const known_annex_files
+	, const known_annex_size
+	]
+local_slow_stats :: [FilePath -> Stat]
+local_slow_stats =
+	[ const numcopies_stats
+	]
+
+stat :: String -> (String -> StatState String) -> Stat
+stat desc a = return $ Just (desc, a desc)
+
+nostat :: Stat
+nostat = return Nothing
+
+json :: JSON j => (j -> String) -> StatState j -> String -> StatState String
+json serialize a desc = do
+	j <- a
+	lift $ maybeShowJSON [(desc, j)]
+	return $ serialize j
+
+nojson :: StatState String -> String -> StatState String
+nojson a _ = a
+
+showStat :: Stat -> StatState ()
+showStat s = maybe noop calc =<< s
+  where
+	calc (desc, a) = do
+		(lift . showHeader) desc
+		lift . showRaw =<< a
+
+repository_mode :: Stat
+repository_mode = stat "repository mode" $ json id $ lift $
+	ifM isDirect 
+		( return "direct", return "indirect" )
+
+remote_list :: TrustLevel -> Stat
+remote_list level = stat n $ nojson $ lift $ do
+	us <- M.keys <$> (M.union <$> uuidMap <*> remoteMap Remote.name)
+	rs <- fst <$> trustPartition level us
+	s <- prettyPrintUUIDs n rs
+	return $ if null s then "0" else show (length rs) ++ "\n" ++ beginning s
+  where
+	n = showTrustLevel level ++ " repositories"
+	
+local_dir :: FilePath -> Stat
+local_dir dir = stat "directory" $ json id $ return dir
+
+local_annex_keys :: Stat
+local_annex_keys = stat "local annex keys" $ json show $
+	countKeys <$> cachedPresentData
+
+local_annex_size :: Stat
+local_annex_size = stat "local annex size" $ json id $
+	showSizeKeys <$> cachedPresentData
+
+known_annex_files :: Stat
+known_annex_files = stat "annexed files in working tree" $ json show $
+	countKeys <$> cachedReferencedData
+
+known_annex_size :: Stat
+known_annex_size = stat "size of annexed files in working tree" $ json id $
+	showSizeKeys <$> cachedReferencedData
+
+tmp_size :: Stat
+tmp_size = staleSize "temporary directory size" gitAnnexTmpDir
+
+bad_data_size :: Stat
+bad_data_size = staleSize "bad keys size" gitAnnexBadDir
+
+bloom_info :: Stat
+bloom_info = stat "bloom filter size" $ json id $ do
+	localkeys <- countKeys <$> cachedPresentData
+	capacity <- fromIntegral <$> lift Command.Unused.bloomCapacity
+	let note = aside $
+		if localkeys >= capacity
+		then "appears too small for this repository; adjust annex.bloomcapacity"
+		else showPercentage 1 (percentage capacity localkeys) ++ " full"
+
+	-- Two bloom filters are used at the same time, so double the size
+	-- of one.
+	size <- roughSize memoryUnits False . (* 2) . fromIntegral . fst <$>
+		lift Command.Unused.bloomBitsHashes
+
+	return $ size ++ note
+
+transfer_list :: Stat
+transfer_list = stat "transfers in progress" $ nojson $ lift $ do
+	uuidmap <- Remote.remoteMap id
+	ts <- getTransfers
+	return $ if null ts
+		then "none"
+		else multiLine $
+			map (uncurry $ line uuidmap) $ sort ts
+  where
+	line uuidmap t i = unwords
+		[ showLcDirection (transferDirection t) ++ "ing"
+		, fromMaybe (key2file $ transferKey t) (associatedFile i)
+		, if transferDirection t == Upload then "to" else "from"
+		, maybe (fromUUID $ transferUUID t) Remote.name $
+			M.lookup (transferUUID t) uuidmap
+		]
+
+disk_size :: Stat
+disk_size = stat "available local disk space" $ json id $ lift $
+	calcfree
+		<$> (annexDiskReserve <$> Annex.getGitConfig)
+		<*> inRepo (getDiskFree . gitAnnexDir)
+  where
+	calcfree reserve (Just have) = unwords
+		[ roughSize storageUnits False $ nonneg $ have - reserve
+		, "(+" ++ roughSize storageUnits False reserve
+		, "reserved)"
+		]			
+	calcfree _ _ = "unknown"
+
+	nonneg x
+		| x >= 0 = x
+		| otherwise = 0
+
+backend_usage :: Stat
+backend_usage = stat "backend usage" $ nojson $
+	calc
+		<$> (backendsKeys <$> cachedReferencedData)
+		<*> (backendsKeys <$> cachedPresentData)
+  where
+	calc x y = multiLine $
+		map (\(n, b) -> b ++ ": " ++ show n) $
+		reverse $ sort $ map swap $ M.toList $
+		M.unionWith (+) x y
+
+numcopies_stats :: Stat
+numcopies_stats = stat "numcopies stats" $ nojson $
+	calc <$> (maybe M.empty numCopiesVarianceMap <$> cachedNumCopiesStats)
+  where
+	calc = multiLine
+		. map (\(variance, count) -> show variance ++ ": " ++ show count)
+		. reverse . sortBy (comparing snd) . M.toList
+
+cachedPresentData :: StatState KeyData
+cachedPresentData = do
+	s <- get
+	case presentData s of
+		Just v -> return v
+		Nothing -> do
+			v <- foldKeys <$> lift getKeysPresent
+			put s { presentData = Just v }
+			return v
+
+cachedReferencedData :: StatState KeyData
+cachedReferencedData = do
+	s <- get
+	case referencedData s of
+		Just v -> return v
+		Nothing -> do
+			!v <- lift $ Command.Unused.withKeysReferenced
+				emptyKeyData addKey
+			put s { referencedData = Just v }
+			return v
+
+-- currently only available for local info
+cachedNumCopiesStats :: StatState (Maybe NumCopiesStats)
+cachedNumCopiesStats = numCopiesStats <$> get
+
+getLocalStatInfo :: FilePath -> Annex StatInfo
+getLocalStatInfo dir = do
+	fast <- Annex.getState Annex.fast
+	matcher <- Limit.getMatcher
+	(presentdata, referenceddata, numcopiesstats) <-
+		Command.Unused.withKeysFilesReferencedIn dir initial
+			(update matcher fast)
+	return $ StatInfo (Just presentdata) (Just referenceddata) (Just numcopiesstats)
+  where
+	initial = (emptyKeyData, emptyKeyData, emptyNumCopiesStats)
+	update matcher fast key file vs@(presentdata, referenceddata, numcopiesstats) =
+		ifM (matcher $ FileInfo file file)
+			( do
+				!presentdata' <- ifM (inAnnex key)
+					( return $ addKey key presentdata
+					, return presentdata
+					)
+				let !referenceddata' = addKey key referenceddata
+				!numcopiesstats' <- if fast
+					then return numcopiesstats
+					else updateNumCopiesStats key file numcopiesstats
+				return $! (presentdata', referenceddata', numcopiesstats')
+			, return vs
+			)
+
+emptyKeyData :: KeyData
+emptyKeyData = KeyData 0 0 0 M.empty
+
+emptyNumCopiesStats :: NumCopiesStats
+emptyNumCopiesStats = NumCopiesStats M.empty
+
+foldKeys :: [Key] -> KeyData
+foldKeys = foldl' (flip addKey) emptyKeyData
+
+addKey :: Key -> KeyData -> KeyData
+addKey key (KeyData count size unknownsize backends) =
+	KeyData count' size' unknownsize' backends'
+  where
+	{- All calculations strict to avoid thunks when repeatedly
+	 - applied to many keys. -}
+	!count' = count + 1
+	!backends' = M.insertWith' (+) (keyBackendName key) 1 backends
+	!size' = maybe size (+ size) ks
+	!unknownsize' = maybe (unknownsize + 1) (const unknownsize) ks
+	ks = keySize key
+
+updateNumCopiesStats :: Key -> FilePath -> NumCopiesStats -> Annex NumCopiesStats
+updateNumCopiesStats key file (NumCopiesStats m) = do
+	!variance <- Variance <$> numCopiesCheck file key (-)
+	let !m' = M.insertWith' (+) variance 1 m
+	let !ret = NumCopiesStats m'
+	return ret
+
+showSizeKeys :: KeyData -> String
+showSizeKeys d = total ++ missingnote
+  where
+	total = roughSize storageUnits False $ sizeKeys d
+	missingnote
+		| unknownSizeKeys d == 0 = ""
+		| otherwise = aside $
+			"+ " ++ show (unknownSizeKeys d) ++
+			" unknown size"
+
+staleSize :: String -> (Git.Repo -> FilePath) -> Stat
+staleSize label dirspec = go =<< lift (dirKeys dirspec)
+  where
+	go [] = nostat
+	go keys = onsize =<< sum <$> keysizes keys
+	onsize 0 = nostat
+	onsize size = stat label $
+		json (++ aside "clean up with git-annex unused") $
+			return $ roughSize storageUnits False size
+	keysizes keys = do
+		dir <- lift $ fromRepo dirspec
+		liftIO $ forM keys $ \k -> catchDefaultIO 0 $
+			fromIntegral . fileSize 
+				<$> getFileStatus (dir </> keyFile k)
+
+aside :: String -> String
+aside s = " (" ++ s ++ ")"
+
+multiLine :: [String] -> String
+multiLine = concatMap (\l -> "\n\t" ++ l)

Command/List.hs

@@ -22,7 +22,7 @@ import Logs.UUID
 import Annex.UUID
 import qualified Option
 import qualified Annex
-import Git.Remote
+import Git.Types (RemoteName)
 
 def :: [Command]
 def = [noCommit $ withOptions [allrepos] $ command "list" paramPaths seek

Command/Map.hs

@@ -74,7 +74,7 @@ drawMap rs umap ts = Dot.graph $ repos ++ trusted ++ others
 
 hostname :: Git.Repo -> String
 hostname r
-	| Git.repoIsUrl r = Git.Url.host r
+	| Git.repoIsUrl r = fromMaybe (Git.repoLocation r) (Git.Url.host r)
 	| otherwise = "localhost"
 
 basehostname :: Git.Repo -> String

Command/Merge.hs

@@ -34,6 +34,5 @@ mergeBranch = do
 
 mergeSynced :: CommandStart
 mergeSynced = do
-	branch <- inRepo Git.Branch.current
 	prepMerge
-	maybe stop mergeLocal branch
+	mergeLocal =<< inRepo Git.Branch.current

Command/Reinject.hs

@@ -14,7 +14,7 @@ import Annex.Content
 import qualified Command.Fsck
 
 def :: [Command]
-def = [notDirect $ command "reinject" (paramPair "SRC" "DEST") seek
+def = [command "reinject" (paramPair "SRC" "DEST") seek
 	SectionUtility "sets content of annexed file"]
 
 seek :: [CommandSeek]

Command/SendKey.hs

@@ -46,6 +46,4 @@ fieldTransfer direction key a = do
 	ok <- maybe (a $ const noop)
 		(\u -> runTransfer (Transfer direction (toUUID u) key) afile noRetry a)
 		=<< Fields.getField Fields.remoteUUID
-	liftIO $ if ok
+	liftIO $ exitBool ok
-		then exitSuccess
-		else exitFailure

Command/Status.hs

@@ -1,384 +1,89 @@
 {- git-annex command
  -
- - Copyright 2011 Joey Hess <joey@kitenet.net>
+ - Copyright 2013 Joey Hess <joey@kitenet.net>
  -
  - Licensed under the GNU GPL version 3 or higher.
  -}
 
-{-# LANGUAGE BangPatterns #-}
-
 module Command.Status where
 
-import "mtl" Control.Monad.State.Strict
-import qualified Data.Map as M
-import Text.JSON
-import Data.Tuple
-import Data.Ord
-import System.PosixCompat.Files
-
 import Common.Annex
-import qualified Remote
-import qualified Command.Unused
-import qualified Git
-import qualified Annex
 import Command
-import Utility.DataUnits
+import Annex.CatFile
-import Utility.DiskFree
+import Annex.Content.Direct
-import Annex.Content
-import Types.Key
-import Logs.UUID
-import Logs.Trust
-import Remote
 import Config
-import Utility.Percentage
+import qualified Git.LsFiles as LsFiles
-import Logs.Transfer
+import qualified Git.Ref
-import Types.TrustLevel
+import qualified Git
-import Types.FileMatcher
-import qualified Limit
-
--- a named computation that produces a statistic
-type Stat = StatState (Maybe (String, StatState String))
-
--- data about a set of keys
-data KeyData = KeyData
-	{ countKeys :: Integer
-	, sizeKeys :: Integer
-	, unknownSizeKeys :: Integer
-	, backendsKeys :: M.Map String Integer
-	}
-
-data NumCopiesStats = NumCopiesStats
-	{ numCopiesVarianceMap :: M.Map Variance Integer
-	}
-
-newtype Variance = Variance Int
-	deriving (Eq, Ord)
-
-instance Show Variance where
-	show (Variance n)
-		| n >= 0 = "numcopies +" ++ show n
-		| otherwise = "numcopies " ++ show n
-
--- cached info that multiple Stats use
-data StatInfo = StatInfo
-	{ presentData :: Maybe KeyData
-	, referencedData :: Maybe KeyData
-	, numCopiesStats :: Maybe NumCopiesStats
-	}
-
--- a state monad for running Stats in
-type StatState = StateT StatInfo Annex
 
 def :: [Command]
-def = [noCommit $ command "status" paramPaths seek
+def = [notBareRepo $ noCommit $ noMessages $
-	SectionQuery "shows status information about the annex"]
+	command "status" paramPaths seek SectionCommon
+		"show the working tree status"]
 
 seek :: [CommandSeek]
-seek = [withWords start]
+seek = 
+	[ withWords start
+	]
 
 start :: [FilePath] -> CommandStart
 start [] = do
-	globalStatus
+	-- Like git status, when run without a directory, behave as if
-	stop
+	-- given the path to the top of the repository.
-start ps = do
+	cwd <- liftIO getCurrentDirectory
-	mapM_ localStatus =<< filterM isdir ps
+	top <- fromRepo Git.repoPath
-	stop
+	next $ perform [relPathDirToFile cwd top]
-  where
+start locs = next $ perform locs
-	isdir = liftIO . catchBoolIO . (isDirectory <$$> getFileStatus)
 	
-globalStatus :: Annex ()
+perform :: [FilePath] -> CommandPerform
-globalStatus = do
+perform locs = do
-	stats <- selStats global_fast_stats global_slow_stats
+	(l, cleanup) <- inRepo $ LsFiles.modifiedOthers locs
-	showCustom "status" $ do
+	getstatus <- ifM isDirect
-		evalStateT (mapM_ showStat stats) (StatInfo Nothing Nothing Nothing)
+		( return statusDirect
-		return True
+		, return $ Just <$$> statusIndirect
-
-localStatus :: FilePath -> Annex ()
-localStatus dir = showCustom (unwords ["status", dir]) $ do
-	stats <- selStats (tostats local_fast_stats) (tostats local_slow_stats)
-	evalStateT (mapM_ showStat stats) =<< getLocalStatInfo dir
-	return True
-  where
-  	tostats = map (\s -> s dir)
-
-selStats :: [Stat] -> [Stat] -> Annex [Stat]
-selStats fast_stats slow_stats = do
-	fast <- Annex.getState Annex.fast
-	return $ if fast
-		then fast_stats
-		else fast_stats ++ slow_stats
-
-{- Order is significant. Less expensive operations, and operations
- - that share data go together.
- -}
-global_fast_stats :: [Stat]
-global_fast_stats = 
-	[ repository_mode
-	, remote_list Trusted
-	, remote_list SemiTrusted
-	, remote_list UnTrusted
-	, transfer_list
-	, disk_size
-	]
-global_slow_stats :: [Stat]
-global_slow_stats = 
-	[ tmp_size
-	, bad_data_size
-	, local_annex_keys
-	, local_annex_size
-	, known_annex_files
-	, known_annex_size
-	, bloom_info
-	, backend_usage
-	]
-local_fast_stats :: [FilePath -> Stat]
-local_fast_stats =
-	[ local_dir
-	, const local_annex_keys
-	, const local_annex_size
-	, const known_annex_files
-	, const known_annex_size
-	]
-local_slow_stats :: [FilePath -> Stat]
-local_slow_stats =
-	[ const numcopies_stats
-	]
-
-stat :: String -> (String -> StatState String) -> Stat
-stat desc a = return $ Just (desc, a desc)
-
-nostat :: Stat
-nostat = return Nothing
-
-json :: JSON j => (j -> String) -> StatState j -> String -> StatState String
-json serialize a desc = do
-	j <- a
-	lift $ maybeShowJSON [(desc, j)]
-	return $ serialize j
-
-nojson :: StatState String -> String -> StatState String
-nojson a _ = a
-
-showStat :: Stat -> StatState ()
-showStat s = maybe noop calc =<< s
-  where
-	calc (desc, a) = do
-		(lift . showHeader) desc
-		lift . showRaw =<< a
-
-repository_mode :: Stat
-repository_mode = stat "repository mode" $ json id $ lift $
-	ifM isDirect 
-		( return "direct", return "indirect" )
-
-remote_list :: TrustLevel -> Stat
-remote_list level = stat n $ nojson $ lift $ do
-	us <- M.keys <$> (M.union <$> uuidMap <*> remoteMap Remote.name)
-	rs <- fst <$> trustPartition level us
-	s <- prettyPrintUUIDs n rs
-	return $ if null s then "0" else show (length rs) ++ "\n" ++ beginning s
-  where
-	n = showTrustLevel level ++ " repositories"
-	
-local_dir :: FilePath -> Stat
-local_dir dir = stat "directory" $ json id $ return dir
-
-local_annex_keys :: Stat
-local_annex_keys = stat "local annex keys" $ json show $
-	countKeys <$> cachedPresentData
-
-local_annex_size :: Stat
-local_annex_size = stat "local annex size" $ json id $
-	showSizeKeys <$> cachedPresentData
-
-known_annex_files :: Stat
-known_annex_files = stat "annexed files in working tree" $ json show $
-	countKeys <$> cachedReferencedData
-
-known_annex_size :: Stat
-known_annex_size = stat "size of annexed files in working tree" $ json id $
-	showSizeKeys <$> cachedReferencedData
-
-tmp_size :: Stat
-tmp_size = staleSize "temporary directory size" gitAnnexTmpDir
-
-bad_data_size :: Stat
-bad_data_size = staleSize "bad keys size" gitAnnexBadDir
-
-bloom_info :: Stat
-bloom_info = stat "bloom filter size" $ json id $ do
-	localkeys <- countKeys <$> cachedPresentData
-	capacity <- fromIntegral <$> lift Command.Unused.bloomCapacity
-	let note = aside $
-		if localkeys >= capacity
-		then "appears too small for this repository; adjust annex.bloomcapacity"
-		else showPercentage 1 (percentage capacity localkeys) ++ " full"
-
-	-- Two bloom filters are used at the same time, so double the size
-	-- of one.
-	size <- roughSize memoryUnits False . (* 2) . fromIntegral . fst <$>
-		lift Command.Unused.bloomBitsHashes
-
-	return $ size ++ note
-
-transfer_list :: Stat
-transfer_list = stat "transfers in progress" $ nojson $ lift $ do
-	uuidmap <- Remote.remoteMap id
-	ts <- getTransfers
-	return $ if null ts
-		then "none"
-		else multiLine $
-			map (uncurry $ line uuidmap) $ sort ts
-  where
-	line uuidmap t i = unwords
-		[ showLcDirection (transferDirection t) ++ "ing"
-		, fromMaybe (key2file $ transferKey t) (associatedFile i)
-		, if transferDirection t == Upload then "to" else "from"
-		, maybe (fromUUID $ transferUUID t) Remote.name $
-			M.lookup (transferUUID t) uuidmap
-		]
-
-disk_size :: Stat
-disk_size = stat "available local disk space" $ json id $ lift $
-	calcfree
-		<$> (annexDiskReserve <$> Annex.getGitConfig)
-		<*> inRepo (getDiskFree . gitAnnexDir)
-  where
-	calcfree reserve (Just have) = unwords
-		[ roughSize storageUnits False $ nonneg $ have - reserve
-		, "(+" ++ roughSize storageUnits False reserve
-		, "reserved)"
-		]			
-	calcfree _ _ = "unknown"
-
-	nonneg x
-		| x >= 0 = x
-		| otherwise = 0
-
-backend_usage :: Stat
-backend_usage = stat "backend usage" $ nojson $
-	calc
-		<$> (backendsKeys <$> cachedReferencedData)
-		<*> (backendsKeys <$> cachedPresentData)
-  where
-	calc x y = multiLine $
-		map (\(n, b) -> b ++ ": " ++ show n) $
-		reverse $ sort $ map swap $ M.toList $
-		M.unionWith (+) x y
-
-numcopies_stats :: Stat
-numcopies_stats = stat "numcopies stats" $ nojson $
-	calc <$> (maybe M.empty numCopiesVarianceMap <$> cachedNumCopiesStats)
-  where
-	calc = multiLine
-		. map (\(variance, count) -> show variance ++ ": " ++ show count)
-		. reverse . sortBy (comparing snd) . M.toList
-
-cachedPresentData :: StatState KeyData
-cachedPresentData = do
-	s <- get
-	case presentData s of
-		Just v -> return v
-		Nothing -> do
-			v <- foldKeys <$> lift getKeysPresent
-			put s { presentData = Just v }
-			return v
-
-cachedReferencedData :: StatState KeyData
-cachedReferencedData = do
-	s <- get
-	case referencedData s of
-		Just v -> return v
-		Nothing -> do
-			!v <- lift $ Command.Unused.withKeysReferenced
-				emptyKeyData addKey
-			put s { referencedData = Just v }
-			return v
-
--- currently only available for local status
-cachedNumCopiesStats :: StatState (Maybe NumCopiesStats)
-cachedNumCopiesStats = numCopiesStats <$> get
-
-getLocalStatInfo :: FilePath -> Annex StatInfo
-getLocalStatInfo dir = do
-	fast <- Annex.getState Annex.fast
-	matcher <- Limit.getMatcher
-	(presentdata, referenceddata, numcopiesstats) <-
-		Command.Unused.withKeysFilesReferencedIn dir initial
-			(update matcher fast)
-	return $ StatInfo (Just presentdata) (Just referenceddata) (Just numcopiesstats)
-  where
-	initial = (emptyKeyData, emptyKeyData, emptyNumCopiesStats)
-	update matcher fast key file vs@(presentdata, referenceddata, numcopiesstats) =
-		ifM (matcher $ FileInfo file file)
-			( do
-				!presentdata' <- ifM (inAnnex key)
-					( return $ addKey key presentdata
-					, return presentdata
 		)
-				let !referenceddata' = addKey key referenceddata
+	forM_ l $ \f -> maybe noop (showFileStatus f) =<< getstatus f
-				!numcopiesstats' <- if fast
+	void $ liftIO cleanup
-					then return numcopiesstats
+	next $ return True
-					else updateNumCopiesStats key file numcopiesstats
+
-				return $! (presentdata', referenceddata', numcopiesstats')
+data Status 
-			, return vs
+	= NewFile
+	| DeletedFile
+	| ModifiedFile
+
+showStatus :: Status -> String
+showStatus NewFile = "?"
+showStatus DeletedFile = "D"
+showStatus ModifiedFile = "M"
+
+showFileStatus :: FilePath -> Status -> Annex ()
+showFileStatus f s  = liftIO $ putStrLn $ showStatus s ++ " " ++ f
+
+statusDirect :: FilePath -> Annex (Maybe Status)
+statusDirect f = checkstatus =<< liftIO (catchMaybeIO $ getFileStatus f)
+  where
+	checkstatus Nothing = return $ Just DeletedFile
+	checkstatus (Just s)
+		-- Git thinks that present direct mode files modifed,
+		-- so have to check.
+		| not (isSymbolicLink s) = checkkey s =<< catKeyFile f
+		| otherwise = Just <$> checkNew f
+	
+	checkkey s (Just k) = ifM (sameFileStatus k s)
+		( return Nothing
+		, return $ Just ModifiedFile
 		)
+	checkkey _ Nothing = Just <$> checkNew f
 
-emptyKeyData :: KeyData
+statusIndirect :: FilePath -> Annex Status
-emptyKeyData = KeyData 0 0 0 M.empty
+statusIndirect f = ifM (liftIO $ isJust <$> catchMaybeIO (getFileStatus f))
-
+	( checkNew f
-emptyNumCopiesStats :: NumCopiesStats
+	, return DeletedFile
-emptyNumCopiesStats = NumCopiesStats M.empty
+	)
-
-foldKeys :: [Key] -> KeyData
-foldKeys = foldl' (flip addKey) emptyKeyData
-
-addKey :: Key -> KeyData -> KeyData
-addKey key (KeyData count size unknownsize backends) =
-	KeyData count' size' unknownsize' backends'
   where
-	{- All calculations strict to avoid thunks when repeatedly
-	 - applied to many keys. -}
-	!count' = count + 1
-	!backends' = M.insertWith' (+) (keyBackendName key) 1 backends
-	!size' = maybe size (+ size) ks
-	!unknownsize' = maybe (unknownsize + 1) (const unknownsize) ks
-	ks = keySize key
 
-updateNumCopiesStats :: Key -> FilePath -> NumCopiesStats -> Annex NumCopiesStats
+checkNew :: FilePath -> Annex Status
-updateNumCopiesStats key file (NumCopiesStats m) = do
+checkNew f = ifM (isJust <$> catObjectDetails (Git.Ref.fileRef f))
-	!variance <- Variance <$> numCopiesCheck file key (-)
+	( return ModifiedFile
-	let !m' = M.insertWith' (+) variance 1 m
+	, return NewFile
-	let !ret = NumCopiesStats m'
+	)
-	return ret
-
-showSizeKeys :: KeyData -> String
-showSizeKeys d = total ++ missingnote
-  where
-	total = roughSize storageUnits False $ sizeKeys d
-	missingnote
-		| unknownSizeKeys d == 0 = ""
-		| otherwise = aside $
-			"+ " ++ show (unknownSizeKeys d) ++
-			" unknown size"
-
-staleSize :: String -> (Git.Repo -> FilePath) -> Stat
-staleSize label dirspec = go =<< lift (dirKeys dirspec)
-  where
-	go [] = nostat
-	go keys = onsize =<< sum <$> keysizes keys
-	onsize 0 = nostat
-	onsize size = stat label $
-		json (++ aside "clean up with git-annex unused") $
-			return $ roughSize storageUnits False size
-	keysizes keys = do
-		dir <- lift $ fromRepo dirspec
-		liftIO $ forM keys $ \k -> catchDefaultIO 0 $
-			fromIntegral . fileSize 
-				<$> getFileStatus (dir </> keyFile k)
-
-aside :: String -> String
-aside s = " (" ++ s ++ ")"
-
-multiLine :: [String] -> String
-multiLine = concatMap (\l -> "\n\t" ++ l)

Command/Sync.hs

@@ -45,12 +45,14 @@ seek rs = do
 	prepMerge
 
 	-- There may not be a branch checked out until after the commit,
-	-- so only look it up once needed, and only look it up once.
+	-- or perhaps after it gets merged from the remote.
+	-- So only look it up once it's needed, and if once there is a
+	-- branch, cache it.
 	mvar <- liftIO newEmptyMVar
 	let getbranch = ifM (liftIO $ isEmptyMVar mvar)
 		( do
-			branch <- fromMaybe (error "no branch is checked out")
+			branch <- inRepo Git.Branch.current
-				<$> inRepo Git.Branch.current
+			when (isJust branch) $
 				liftIO $ putMVar mvar branch
 			return branch
 		, liftIO $ readMVar mvar
@@ -73,10 +75,10 @@ prepMerge :: Annex ()
 prepMerge = liftIO . setCurrentDirectory =<< fromRepo Git.repoPath
 
 syncBranch :: Git.Ref -> Git.Ref
-syncBranch = Git.Ref.under "refs/heads/synced/"
+syncBranch = Git.Ref.under "refs/heads/synced" . fromDirectBranch
 
 remoteBranch :: Remote -> Git.Ref -> Git.Ref
-remoteBranch remote = Git.Ref.under $ "refs/remotes/" ++ Remote.name remote
+remoteBranch remote = Git.Ref.underBase $ "refs/remotes/" ++ Remote.name remote
 
 syncRemotes :: [String] -> Annex [Remote]
 syncRemotes rs = ifM (Annex.getState Annex.fast) ( nub <$> pickfast , wanted )
@@ -116,8 +118,9 @@ commit = next $ next $ ifM isDirect
 		_ <- inRepo $ tryIO . Git.Command.runQuiet params
 		return True
 
-mergeLocal :: Git.Ref -> CommandStart
+mergeLocal :: Maybe Git.Ref -> CommandStart
-mergeLocal branch = go =<< needmerge
+mergeLocal Nothing = stop
+mergeLocal (Just branch) = go =<< needmerge
   where
 	syncbranch = syncBranch branch
 	needmerge = ifM isBareRepo
@@ -132,9 +135,16 @@ mergeLocal branch = go =<< needmerge
 		showStart "merge" $ Git.Ref.describe syncbranch
 		next $ next $ mergeFrom syncbranch
 
-pushLocal :: Git.Ref -> CommandStart
+pushLocal :: Maybe Git.Ref -> CommandStart
-pushLocal branch = do
+pushLocal Nothing = stop
+pushLocal (Just branch) = do
+	-- Update the sync branch to match the new state of the branch
 	inRepo $ updateBranch $ syncBranch branch
+	-- In direct mode, we're operating on some special direct mode
+	-- branch, rather than the intended branch, so update the indended
+	-- branch.
+	whenM isDirect $
+		inRepo $ updateBranch $ fromDirectBranch branch
 	stop
 
 updateBranch :: Git.Ref -> Git.Repo -> IO ()
@@ -147,13 +157,13 @@ updateBranch syncbranch g =
 		, Param $ show $ Git.Ref.base syncbranch
 		] g
 
-pullRemote :: Remote -> Git.Ref -> CommandStart
+pullRemote :: Remote -> Maybe Git.Ref -> CommandStart
 pullRemote remote branch = do
 	showStart "pull" (Remote.name remote)
 	next $ do
 		showOutput
 		stopUnless fetch $
-			next $ mergeRemote remote (Just branch)
+			next $ mergeRemote remote branch
   where
 	fetch = inRepo $ Git.Command.runBool
 		[Param "fetch", Param $ Remote.name remote]
@@ -175,8 +185,9 @@ mergeRemote remote b = case b of
 	branchlist Nothing = []
 	branchlist (Just branch) = [branch, syncBranch branch]
 
-pushRemote :: Remote -> Git.Ref -> CommandStart
+pushRemote :: Remote -> Maybe Git.Ref -> CommandStart
-pushRemote remote branch = go =<< needpush
+pushRemote _remote Nothing = stop
+pushRemote remote (Just branch) = go =<< needpush
   where
 	needpush = anyM (newer remote) [syncBranch branch, Annex.Branch.name]
 	go False = stop
@@ -227,7 +238,7 @@ pushBranch remote branch g = tryIO (directpush g) `after` syncpush g
 		, refspec branch
 		]
 	directpush = Git.Command.runQuiet $ pushparams
-		[show $ Git.Ref.base branch]
+		[show $ Git.Ref.base $ fromDirectBranch branch]
 	pushparams branches =
 		[ Param "push"
 		, Param $ Remote.name remote
@@ -310,6 +321,7 @@ resolveMerge = do
 			, 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' :: LsFiles.Unmerged -> Annex (Maybe FilePath)

Command/TransferKey.hs

@@ -56,4 +56,4 @@ fromPerform remote key file = go $
 		getViaTmp key $ \t -> Remote.retrieveKeyFile remote key file t p
 
 go :: Annex Bool -> CommandPerform
-go a = ifM a ( liftIO exitSuccess,  liftIO exitFailure)
+go a = a >>= liftIO . exitBool

Command/Unused.hs

@@ -332,11 +332,13 @@ withUnusedMaps a params = do
 	unused <- readUnusedLog ""
 	unusedbad <- readUnusedLog "bad"
 	unusedtmp <- readUnusedLog "tmp"
+	let m = unused `M.union` unusedbad `M.union` unusedtmp
 	return $ map (a $ UnusedMaps unused unusedbad unusedtmp) $
-		concatMap unusedSpec params
+		concatMap (unusedSpec m) params
 
-unusedSpec :: String -> [Int]
+unusedSpec :: UnusedMap -> String -> [Int]
-unusedSpec spec
+unusedSpec m spec
+	| spec == "all" = [fst (M.findMin m)..fst (M.findMax m)]
 	| "-" `isInfixOf` spec = range $ separate (== '-') spec
 	| otherwise = maybe badspec (: []) (readish spec)
   where

Command/Upgrade.hs

@@ -11,6 +11,7 @@ import Common.Annex
 import Command
 import Upgrade
 import Annex.Version
+import Config
 
 def :: [Command]
 def = [dontCheck repoExists $ -- because an old version may not seem to exist
@@ -23,6 +24,5 @@ seek = [withNothing start]
 start :: CommandStart
 start = do
 	showStart "upgrade" "."
-	r <- upgrade
+	r <- upgrade False
-	setVersion defaultVersion
 	next $ next $ return r

Command/Watch.hs

@@ -32,5 +32,5 @@ start :: Bool -> Bool -> Bool -> Maybe Duration -> CommandStart
 start assistant foreground stopdaemon startdelay = do
 	if stopdaemon
 		then stopDaemon
-		else startDaemon assistant foreground startdelay Nothing Nothing -- does not return
+		else startDaemon assistant foreground startdelay Nothing Nothing Nothing -- does not return
 	stop

Command/WebApp.hs

@@ -30,6 +30,8 @@ import qualified Git.CurrentRepo
 import qualified Annex
 import Config.Files
 import qualified Option
+import Upgrade
+import Annex.Version
 
 import Control.Concurrent
 import Control.Concurrent.STM
@@ -56,10 +58,14 @@ start = start' True
 start' :: Bool -> Maybe HostName -> CommandStart
 start' allowauto listenhost = do
 	liftIO ensureInstalled
-	ifM isInitialized ( go , auto )
+	ifM isInitialized 
+		( go
+		, auto
+		)
 	stop
   where
 	go = do
+		cannotrun <- needsUpgrade . fromMaybe (error "no version") =<< getVersion
 		browser <- fromRepo webBrowser
 		f <- liftIO . absPath =<< fromRepo gitAnnexHtmlShim
 		ifM (checkpid <&&> checkshim f)
@@ -69,7 +75,7 @@ start' allowauto listenhost = do
 					url <- liftIO . readFile
 						=<< fromRepo gitAnnexUrlFile
 					liftIO $ openBrowser browser f url Nothing Nothing
-			, startDaemon True True Nothing listenhost $ Just $ 
+			, startDaemon True True Nothing cannotrun listenhost $ Just $ 
 				\origout origerr url htmlshim ->
 					if isJust listenhost
 						then maybe noop (`hPutStrLn` url) origout
@@ -133,7 +139,7 @@ firstRun listenhost = do
 	let callback a = Just $ a v
 	runAssistant d $ do
 		startNamedThread urlrenderer $
-			webAppThread d urlrenderer True listenhost
+			webAppThread d urlrenderer True Nothing listenhost
 				(callback signaler)
 				(callback mainthread)
 		waitNamedThreads
@@ -155,7 +161,7 @@ firstRun listenhost = do
 			_wait <- takeMVar v
 			state <- Annex.new =<< Git.CurrentRepo.get
 			Annex.eval state $
-				startDaemon True True Nothing listenhost $ Just $
+				startDaemon True True Nothing Nothing listenhost $ Just $
 					sendurlback v
 	sendurlback v _origout _origerr url _htmlshim = do
 		recordUrl url

Config.hs

@@ -71,11 +71,6 @@ getNumCopies Nothing = annexNumCopies <$> Annex.getGitConfig
 isDirect :: Annex Bool
 isDirect = annexDirect <$> Annex.getGitConfig
 
-setDirect :: Bool -> Annex ()
-setDirect b = do
-	setConfig (annexConfig "direct") (Git.Config.boolConfig b)
-	Annex.changeGitConfig $ \c -> c { annexDirect = b }
-
 crippledFileSystem :: Annex Bool
 crippledFileSystem = annexCrippledFileSystem <$> Annex.getGitConfig
 

Git/Branch.hs

@@ -13,7 +13,7 @@ import Common
 import Git
 import Git.Sha
 import Git.Command
-import Git.Ref (headRef)
+import qualified Git.Ref
 
 {- The currently checked out branch.
  -
@@ -36,7 +36,7 @@ current r = do
 {- The current branch, which may not really exist yet. -}
 currentUnsafe :: Repo -> IO (Maybe Git.Ref)
 currentUnsafe r = parse . firstLine
-	<$> pipeReadStrict [Param "symbolic-ref", Param $ show headRef] r
+	<$> pipeReadStrict [Param "symbolic-ref", Param $ show Git.Ref.headRef] r
   where
 	parse l
 		| null l = Nothing
@@ -97,7 +97,7 @@ commit message branch parentrefs repo = do
 	sha <- getSha "commit-tree" $ pipeWriteRead
 		(map Param $ ["commit-tree", show tree] ++ ps)
 		(Just $ flip hPutStr message) repo
-	run [Param "update-ref", Param $ show branch, Param $ show sha] repo
+	update branch sha repo
 	return sha
   where
 	ps = concatMap (\r -> ["-p", show r]) parentrefs
@@ -105,3 +105,29 @@ commit message branch parentrefs repo = do
 {- A leading + makes git-push force pushing a branch. -}
 forcePush :: String -> String
 forcePush b = "+" ++ b
+
+{- Updates a branch (or other ref) to a new Sha. -}
+update :: Branch -> Sha -> Repo -> IO ()
+update branch sha = run 
+	[ Param "update-ref"
+	, Param $ show branch
+	, Param $ show sha
+	]
+
+{- Checks out a branch, creating it if necessary. -}
+checkout :: Branch -> Repo -> IO ()
+checkout branch = run
+	[ Param "checkout"
+	, Param "-q"
+	, Param "-B"
+	, Param $ show $ Git.Ref.base branch
+	]
+
+{- Removes a branch. -}
+delete :: Branch -> Repo -> IO ()
+delete branch = run
+	[ Param "branch"
+	, Param "-q"
+	, Param "-D"
+	, Param $ show $ Git.Ref.base branch
+	]

Git/Command.hs

@@ -21,7 +21,8 @@ import Git.FilePath
 
 {- Constructs a git command line operating on the specified repo. -}
 gitCommandLine :: [CommandParam] -> Repo -> [CommandParam]
-gitCommandLine params Repo { location = l@(Local _ _ ) } = setdir : settree ++ params
+gitCommandLine params r@(Repo { location = l@(Local _ _ ) }) =
+	setdir : settree ++ gitGlobalOpts r ++ params
   where
 	setdir = Param $ "--git-dir=" ++ gitpath (gitdir l)
 	settree = case worktree l of

Git/Config.hs

@@ -110,8 +110,13 @@ store s repo = do
  -}
 updateLocation :: Repo -> IO Repo
 updateLocation r@(Repo { location = LocalUnknown d })
-	| isBare r = updateLocation' r $ Local d Nothing
+	| isBare r = ifM (doesDirectoryExist dotgit)
-	| otherwise = updateLocation' r $ Local (d </> ".git") (Just d)
+			( updateLocation' r $ Local dotgit Nothing
+			, updateLocation' r $ Local d Nothing
+			)
+	| otherwise = updateLocation' r $ Local dotgit (Just d)
+  where
+	dotgit = (d </> ".git")
 updateLocation r@(Repo { location = l@(Local {}) }) = updateLocation' r l
 updateLocation r = return r
 
@@ -153,7 +158,10 @@ boolConfig True = "true"
 boolConfig False = "false"
 
 isBare :: Repo -> Bool
-isBare r = fromMaybe False $ isTrue =<< getMaybe "core.bare" r
+isBare r = fromMaybe False $ isTrue =<< getMaybe coreBare r
+
+coreBare :: String
+coreBare = "core.bare"
 
 {- Runs a command to get the configuration of a repo,
  - and returns a repo populated with the configuration, as well as the raw

Git/Construct.hs

@@ -104,14 +104,16 @@ localToUrl :: Repo -> Repo -> Repo
 localToUrl reference r
 	| not $ repoIsUrl reference = error "internal error; reference repo not url"
 	| repoIsUrl r = r
-	| otherwise = r { location = Url $ fromJust $ parseURI absurl }
+	| otherwise = case Url.authority reference of
-  where
+		Nothing -> r
-	absurl = concat
+		Just auth -> 
+			let absurl = concat
 				[ Url.scheme reference
 				, "//"
-		, Url.authority reference
+				, auth
 				, repoPath r
 				]
+			in r { location = Url $ fromJust $ parseURI absurl }
 
 {- Calculates a list of a repo's configured remotes, by parsing its config. -}
 fromRemotes :: Repo -> IO [Repo]
@@ -228,6 +230,7 @@ newFrom l = return Repo
 	, remotes = []
 	, remoteName = Nothing
 	, gitEnv = Nothing
+	, gitGlobalOpts = []
 	}
 
 

Git/Fsck.hs

@@ -17,7 +17,6 @@ import Common
 import Git
 import Git.Command
 import Git.Sha
-import Git.CatFile
 import Utility.Batch
 
 import qualified Data.Set as S
@@ -40,7 +39,7 @@ type FsckResults = Maybe MissingObjects
 findBroken :: Bool -> Repo -> IO FsckResults
 findBroken batchmode r = do
 	(output, fsckok) <- processTranscript command' (toCommand params') Nothing
-	let objs = parseFsckOutput output
+	let objs = findShas output
 	badobjs <- findMissing objs r
 	if S.null badobjs && not fsckok
 		then return Nothing
@@ -57,30 +56,23 @@ foundBroken (Just s) = not (S.null s)
 
 {- Finds objects that are missing from the git repsitory, or are corrupt.
  -
- - Note that catting a corrupt object will cause cat-file to crash;
+ - This does not use git cat-file --batch, because catting a corrupt
- - this is detected and it's restarted.
+ - object can cause it to crash, or to report incorrect size information.a
  -}
 findMissing :: [Sha] -> Repo -> IO MissingObjects
-findMissing objs r = go objs [] =<< start
+findMissing objs r = S.fromList <$> filterM (not <$$> present) objs
   where
-	start = catFileStart' False r
+	present o = either (const False) (const True) <$> tryIO (dump o)
-	go [] c h = do
+	dump o = runQuiet
-		catFileStop h
+		[ Param "show"
-		return $ S.fromList c
+		, Param (show o)
-	go (o:os) c h = do
+		] r
-		v <- tryIO $ isNothing <$> catObjectDetails h o
-		case v of
-			Left _ -> do
-				void $ tryIO $ catFileStop h
-				go os (o:c) =<< start
-			Right True -> go os (o:c) h
-			Right False -> go os c h
 
-parseFsckOutput :: String -> [Sha]
+findShas :: String -> [Sha]
-parseFsckOutput = catMaybes . map extractSha . concat . map words . lines
+findShas = catMaybes . map extractSha . concat . map words . lines
 
 fsckParams :: Repo -> [CommandParam]
-fsckParams = gitCommandLine
+fsckParams = gitCommandLine $
 	[ Param "fsck"
 	, Param "--no-dangling"
 	, Param "--no-reflogs"

Git/GCrypt.hs

@@ -15,7 +15,6 @@ import Git.Construct
 import qualified Git.Config as Config
 import qualified Git.Command as Command
 import Utility.Gpg
-import Git.Remote
 
 urlPrefix :: String
 urlPrefix = "gcrypt::"

Git/Hook.hs

@@ -0,0 +1,54 @@
+{- git hooks
+ -
+ - Copyright 2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Git.Hook where
+
+import Common
+import Git
+import Utility.Tmp
+
+data Hook = Hook
+	{ hookName :: FilePath
+	, hookScript :: String
+	}
+
+hookFile :: Hook -> Repo -> FilePath
+hookFile h r = localGitDir r </> "hooks" </> hookName h
+
+{- Writes a hook. Returns False if the hook already exists with a different
+ - content. -}
+hookWrite :: Hook -> Repo -> IO Bool
+hookWrite h r = do
+	let f = hookFile h r
+	ifM (doesFileExist f)
+		( expectedContent h r
+		, do
+			viaTmp writeFile f (hookScript h)
+			p <- getPermissions f
+			setPermissions f $ p {executable = True}
+			return True
+		)
+
+{- Removes a hook. Returns False if the hook contained something else, and
+ - could not be removed. -}
+hookUnWrite :: Hook -> Repo -> IO Bool
+hookUnWrite h r = do
+	let f = hookFile h r
+	ifM (doesFileExist f)
+		( ifM (expectedContent h r)
+			( do
+				removeFile f
+				return True
+			, return False
+			)
+		, return True
+		)
+
+expectedContent :: Hook -> Repo -> IO Bool
+expectedContent h r = do
+	content <- readFile $ hookFile h r
+	return $ content == hookScript h

Git/LsFiles.hs

@@ -11,6 +11,7 @@ module Git.LsFiles (
 	allFiles,
 	deleted,
 	modified,
+	modifiedOthers,
 	staged,
 	stagedNotDeleted,
 	stagedOthersDetails,
@@ -65,6 +66,12 @@ modified l repo = pipeNullSplit params repo
   where
 	params = [Params "ls-files --modified -z --"] ++ map File l
 
+{- Files that have been modified or are not checked into git. -}
+modifiedOthers :: [FilePath] -> Repo -> IO ([FilePath], IO Bool)
+modifiedOthers l repo = pipeNullSplit params repo
+  where
+	params = [Params "ls-files --modified --others -z --"] ++ map File l
+
 {- Returns a list of all files that are staged for commit. -}
 staged :: [FilePath] -> Repo -> IO ([FilePath], IO Bool)
 staged = staged' []

Git/Objects.hs

@@ -9,6 +9,7 @@ module Git.Objects where
 
 import Common
 import Git
+import Git.Sha
 
 objectsDir :: Repo -> FilePath
 objectsDir r = localGitDir r </> "objects"
@@ -16,12 +17,17 @@ objectsDir r = localGitDir r </> "objects"
 packDir :: Repo -> FilePath
 packDir r = objectsDir r </> "pack"
 
+packIdxFile :: FilePath -> FilePath
+packIdxFile = flip replaceExtension "idx"
+
 listPackFiles :: Repo -> IO [FilePath]
 listPackFiles r = filter (".pack" `isSuffixOf`) 
 	<$> catchDefaultIO [] (dirContents $ packDir r)
 
-packIdxFile :: FilePath -> FilePath
+listLooseObjectShas :: Repo -> IO [Sha]
-packIdxFile = flip replaceExtension "idx"
+listLooseObjectShas r = catchDefaultIO [] $
+	mapMaybe (extractSha . concat . reverse . take 2 . reverse . splitDirectories)
+		<$> dirContentsRecursiveSkipping (== "pack") (objectsDir r)
 
 looseObjectFile :: Repo -> Sha -> FilePath
 looseObjectFile r sha = objectsDir r </> prefix </> rest

Git/Ref.hs

@@ -29,17 +29,42 @@ base = Ref . remove "refs/heads/" . remove "refs/remotes/" . show
 		| prefix `isPrefixOf` s = drop (length prefix) s
 		| otherwise = s
 
+{- Given a directory and any ref, takes the basename of the ref and puts
+ - it under the directory. -}
+under :: String -> Ref -> Ref
+under dir r = Ref $ dir ++ "/" ++
+	(reverse $ takeWhile (/= '/') $ reverse $ show r)
+
 {- Given a directory such as "refs/remotes/origin", and a ref such as
  - refs/heads/master, yields a version of that ref under the directory,
  - such as refs/remotes/origin/master. -}
-under :: String -> Ref -> Ref
+underBase :: String -> Ref -> Ref
-under dir r = Ref $ dir </> show (base r)
+underBase dir r = Ref $ dir ++ "/" ++ show (base r)
+
+{- A Ref that can be used to refer to a file in the repository, as staged
+ - in the index.
+ -
+ - Prefixing the file with ./ makes this work even if in a subdirectory
+ - of a repo.
+ -}
+fileRef :: FilePath -> Ref
+fileRef f = Ref $ ":./" ++ f
+
+{- A Ref that can be used to refer to a file in the repository as it
+ - appears in a given Ref. -}
+fileFromRef :: Ref -> FilePath -> Ref
+fileFromRef (Ref r) f = let (Ref fr) = fileRef f in Ref (r ++ fr)
 
 {- Checks if a ref exists. -}
 exists :: Ref -> Repo -> IO Bool
 exists ref = runBool
 	[Param "show-ref", Param "--verify", Param "-q", Param $ show ref]
 
+{- The file used to record a ref. (Git also stores some refs in a
+ - packed-refs file.) -}
+file :: Ref -> Repo -> FilePath
+file ref repo = localGitDir repo </> show ref
+
 {- Checks if HEAD exists. It generally will, except for in a repository
  - that was just created. -}
 headExists :: Repo -> IO Bool

Git/Remote.hs

@@ -11,6 +11,7 @@ module Git.Remote where
 
 import Common
 import Git
+import Git.Types
 import qualified Git.Command
 import qualified Git.BuildVersion
 
@@ -21,8 +22,6 @@ import Network.URI
 import Git.FilePath
 #endif
 
-type RemoteName = String
-
 {- Construct a legal git remote name out of an arbitrary input string.
  -
  - There seems to be no formal definition of this in the git source,
@@ -62,6 +61,10 @@ remoteLocationIsUrl :: RemoteLocation -> Bool
 remoteLocationIsUrl (RemoteUrl _) = True
 remoteLocationIsUrl _ = False
 
+remoteLocationIsSshUrl :: RemoteLocation -> Bool
+remoteLocationIsSshUrl (RemoteUrl u) = "ssh://" `isPrefixOf` u
+remoteLocationIsSshUrl _ = False
+
 {- Determines if a given remote location is an url, or a local
  - path. Takes the repository's insteadOf configuration into account. -}
 parseRemoteLocation :: String -> Repo -> RemoteLocation

Git/Repair.hs

@@ -8,12 +8,14 @@
 module Git.Repair (
 	runRepair,
 	runRepairOf,
+	successfulRepair,
 	cleanCorruptObjects,
 	retrieveMissingObjects,
 	resetLocalBranches,
 	removeTrackingBranches,
-	rewriteIndex,
 	checkIndex,
+	missingIndex,
+	nukeIndex,
 	emptyGoodCommits,
 ) where
 
@@ -34,71 +36,38 @@ import qualified Git.UpdateIndex as UpdateIndex
 import qualified Git.Branch as Branch
 import Utility.Tmp
 import Utility.Rsync
+import Utility.FileMode
 
 import qualified Data.Set as S
 import qualified Data.ByteString.Lazy as L
 import Data.Tuple.Utils
 
-{- Given a set of bad objects found by git fsck, removes all
+{- Given a set of bad objects found by git fsck, which may not
- - corrupt objects, and returns a list of missing objects,
+ - be complete, finds and removes all corrupt objects, and
- - which need to be found elsewhere to finish recovery.
+ - returns a list of missing objects, which need to be
- -
+ - found elsewhere to finish recovery.
- - Since git fsck may crash on corrupt objects, and so not
- - report the full set of corrupt or missing objects,
- - this removes corrupt objects, and re-runs fsck, until it
- - stabalizes.
- -
- - To remove corrupt objects, unpack all packs, and remove the packs
- - (to handle corrupt packs), and remove loose object files.
  -}
-cleanCorruptObjects :: FsckResults -> Repo -> IO MissingObjects
+cleanCorruptObjects :: FsckResults -> Repo -> IO (Maybe MissingObjects)
-cleanCorruptObjects mmissing r = check mmissing
+cleanCorruptObjects fsckresults r = do
-  where
+	void $ explodePacks r
-	check Nothing = do
+	objs <- listLooseObjectShas r
-		putStrLn "git fsck found a problem but no specific broken objects. Perhaps a corrupt pack file?"
+	bad <- findMissing objs r
-		ifM (explodePacks r)
+	void $ removeLoose r $ S.union bad (fromMaybe S.empty fsckresults)
-			( retry S.empty
+	-- Rather than returning the loose objects that were removed, re-run
-			, return S.empty
+	-- fsck. Other missing objects may have been in the packs,
-			)
+	-- and this way fsck will find them.
-	check (Just bad)
+	findBroken False r
-		| S.null bad = return S.empty
-		| otherwise = do
-			putStrLn $ unwords 
-				[ "git fsck found"
-				, show (S.size bad)
-				, "broken objects."
-				]
-			exploded <- explodePacks r
-			removed <- removeLoose r bad
-			if exploded || removed
-				then retry bad
-				else return bad
-	retry oldbad = do
-		putStrLn "Re-running git fsck to see if it finds more problems."
-		v <- findBroken False r
-		case v of
-			Nothing -> error $ unwords
-				[ "git fsck found a problem, which was not corrected after removing"
-				, show (S.size oldbad)
-				, "corrupt objects."
-				]
-			Just newbad -> do
-				removed <- removeLoose r newbad
-				let s = S.union oldbad newbad
-				if not removed || s == oldbad
-					then return s
-					else retry s
 
 removeLoose :: Repo -> MissingObjects -> IO Bool
 removeLoose r s = do
-	let fs = map (looseObjectFile r) (S.toList s)
+	fs <- filterM doesFileExist (map (looseObjectFile r) (S.toList s))
-	count <- length <$> filterM doesFileExist fs
+	let count = length fs
-	if (count > 0)
+	if count > 0
 		then do
 			putStrLn $ unwords
-				[ "removing"
+				[ "Removing"
 				, show count
-				, "corrupt loose objects"
+				, "corrupt loose objects."
 				]
 			mapM_ nukeFile fs
 			return True
@@ -114,13 +83,14 @@ explodePacks r = do
 			mapM_ go packs
 			return True
   where
-	go packfile = do
+	go packfile = withTmpFileIn (localGitDir r) "pack" $ \tmp _ -> do
+		moveFile packfile tmp
+		nukeFile $ packIdxFile packfile
+		allowRead tmp
 		-- May fail, if pack file is corrupt.
 		void $ tryIO $
-			pipeWrite [Param "unpack-objects"] r $ \h ->
+			pipeWrite [Param "unpack-objects", Param "-r"] r $ \h ->
-				L.hPut h =<< L.readFile packfile
+				L.hPut h =<< L.readFile tmp
-		nukeFile packfile
-		nukeFile $ packIdxFile packfile
 
 {- Try to retrieve a set of missing objects, from the remotes of a
  - repository. Returns any that could not be retreived.
@@ -128,43 +98,47 @@ explodePacks r = do
  - If another clone of the repository exists locally, which might not be a
  - remote of the repo being repaired, its path can be passed as a reference
  - repository.
+ 
+ - Can also be run with Nothing, if it's not known which objects are
+ - missing, just that some are. (Ie, fsck failed badly.)
  -}
-retrieveMissingObjects :: MissingObjects -> Maybe FilePath -> Repo -> IO MissingObjects
+retrieveMissingObjects :: Maybe MissingObjects -> Maybe FilePath -> Repo -> IO (Maybe MissingObjects)
 retrieveMissingObjects missing referencerepo r
-	| S.null missing = return missing
+	| missing == Just S.empty = return $ Just S.empty
 	| otherwise = withTmpDir "tmprepo" $ \tmpdir -> do
 		unlessM (boolSystem "git" [Params "init", File tmpdir]) $
 			error $ "failed to create temp repository in " ++ tmpdir
 		tmpr <- Config.read =<< Construct.fromAbsPath tmpdir
 		stillmissing <- pullremotes tmpr (remotes r) fetchrefstags missing
-		if S.null stillmissing
+		if stillmissing == Just S.empty
-			then return stillmissing
+			then return $ Just S.empty
 			else pullremotes tmpr (remotes r) fetchallrefs stillmissing
   where
 	pullremotes tmpr [] fetchrefs stillmissing = case referencerepo of
 		Nothing -> return stillmissing
 		Just p -> ifM (fetchfrom p fetchrefs tmpr)
 			( do
+				void $ explodePacks tmpr
 				void $ copyObjects tmpr r
-				findMissing (S.toList stillmissing) r
+				case stillmissing of
+					Nothing -> return $ Just S.empty
+					Just s -> Just <$> findMissing (S.toList s) r
 			, return stillmissing
 			)
-	pullremotes tmpr (rmt:rmts) fetchrefs s
+	pullremotes tmpr (rmt:rmts) fetchrefs ms
-		| S.null s = return s
+		| ms == Just S.empty = return $ Just S.empty
 		| otherwise = do
-			putStrLn $ "Trying to recover missing objects from remote " ++ repoDescribe rmt
+			putStrLn $ "Trying to recover missing objects from remote " ++ repoDescribe rmt ++ "."
 			ifM (fetchfrom (repoLocation rmt) fetchrefs tmpr)
 				( do
+					void $ explodePacks tmpr
 					void $ copyObjects tmpr r
+					case ms of
+						Nothing -> pullremotes tmpr rmts fetchrefs ms
+						Just s -> do
 							stillmissing <- findMissing (S.toList s) r
-					pullremotes tmpr rmts fetchrefs stillmissing
+							pullremotes tmpr rmts fetchrefs (Just stillmissing)
-				, do
+				, pullremotes tmpr rmts fetchrefs ms
-					putStrLn $ unwords
-						[ "failed to fetch from remote"
-						, repoDescribe rmt
-						, "(will continue without it, but making this remote available may improve recovery)"
-						]
-					pullremotes tmpr rmts fetchrefs s
 				)
 	fetchfrom fetchurl ps = runBool $
 		[ Param "fetch"
@@ -178,7 +152,7 @@ retrieveMissingObjects missing referencerepo r
 	fetchallrefs = [ Param "+*:*" ]
 
 {- Copies all objects from the src repository to the dest repository.
- - This is done using rsync, so it copies all missing object, and all
+ - This is done using rsync, so it copies all missing objects, and all
  - objects they rely on. -}
 copyObjects :: Repo -> Repo -> IO Bool
 copyObjects srcr destr = rsync
@@ -237,51 +211,44 @@ removeTrackingBranches missing goodcommits r =
 {- Gets all refs, including ones that are corrupt.
  - git show-ref does not output refs to commits that are directly
  - corrupted, so it is not used.
+ -
+ - Relies on packed refs being exploded before it's called.
  -}
 getAllRefs :: Repo -> IO [Ref]
-getAllRefs r = do
+getAllRefs r = map toref <$> dirContentsRecursive refdir
-	packedrs <- mapMaybe parsePacked . lines
-		<$> catchDefaultIO "" (readFile $ packedRefsFile r)
-	loosers <- map toref <$> dirContentsRecursive refdir
-	return $ packedrs ++ loosers
   where
   	refdir = localGitDir r </> "refs"
 	toref = Ref . relPathDirToFile (localGitDir r)
 
+explodePackedRefsFile :: Repo -> IO ()
+explodePackedRefsFile r = do
+	let f = packedRefsFile r
+	whenM (doesFileExist f) $ do
+		rs <- mapMaybe parsePacked . lines
+			<$> catchDefaultIO "" (safeReadFile f)
+		forM_ rs makeref
+		nukeFile f
+  where
+	makeref (sha, ref) = do
+		let dest = localGitDir r ++ show ref
+		createDirectoryIfMissing True (parentDir dest)
+		unlessM (doesFileExist dest) $
+			writeFile dest (show sha)
+
 packedRefsFile :: Repo -> FilePath
 packedRefsFile r = localGitDir r </> "packed-refs"
 
-parsePacked :: String -> Maybe Ref
+parsePacked :: String -> Maybe (Sha, Ref)
 parsePacked l = case words l of
 	(sha:ref:[])
-		| isJust (extractSha sha) -> Just $ Ref ref
+		| isJust (extractSha sha) && Ref.legal True ref ->
+			Just (Ref sha, Ref ref)
 	_ -> Nothing
 
 {- git-branch -d cannot be used to remove a branch that is directly
- - pointing to a corrupt commit. However, it's tried first. -}
+ - pointing to a corrupt commit. -}
 nukeBranchRef :: Branch -> Repo -> IO ()
-nukeBranchRef b r = void $ usegit <||> byhand
+nukeBranchRef b r = nukeFile $ localGitDir r </> show b
-  where
-	usegit = runBool
-		[ Param "branch"
-		, Params "-r -d"
-		, Param $ show $ Ref.base b
-		] r
-	byhand = do
-		nukeFile $ localGitDir r </> show b
-		whenM (doesFileExist packedrefs) $
-			withTmpFile "packed-refs" $ \tmp h -> do
-				ls <- lines <$> readFile packedrefs
-				hPutStr h $ unlines $
-					filter (not . skiprefline) ls
-				hClose h
-				renameFile tmp packedrefs
-		return True
-	skiprefline l = case parsePacked l of
-		Just packedref
-			| packedref == b -> True
-		_ -> False
-	packedrefs = packedRefsFile r
 
 {- Finds the most recent commit to a branch that does not need any
  - of the missing objects. If the input branch is good as-is, returns it.
@@ -368,7 +335,9 @@ verifyTree missing treesha r
 			-- as long as ls-tree succeeded, we're good
 			else cleanup
 
-{- Checks that the index file only refers to objects that are not missing. -}
+{- Checks that the index file only refers to objects that are not missing,
+ - and is not itself corrupt. Note that a missing index file is not
+ - considered a problem (repo may be new). -}
 checkIndex :: MissingObjects -> Repo -> IO Bool
 checkIndex missing r = do
 	(bad, _good, cleanup) <- partitionIndex missing r
@@ -378,6 +347,9 @@ checkIndex missing r = do
 			void cleanup
 			return False
 
+missingIndex :: Repo -> IO Bool
+missingIndex r = not <$> doesFileExist (localGitDir r </> "index")
+
 partitionIndex :: MissingObjects -> Repo -> IO ([LsFiles.StagedDetails], [LsFiles.StagedDetails], IO Bool)
 partitionIndex missing r = do
 	(indexcontents, cleanup) <- LsFiles.stagedDetails [repoPath r] r
@@ -396,7 +368,7 @@ rewriteIndex missing r
 	| otherwise = do
 		(bad, good, cleanup) <- partitionIndex missing r
 		unless (null bad) $ do
-			nukeFile (localGitDir r </> "index")
+			nukeIndex r
 			UpdateIndex.streamUpdateIndex r
 				=<< (catMaybes <$> mapM reinject good)
 		void cleanup
@@ -408,6 +380,9 @@ rewriteIndex missing r
 			UpdateIndex.stageFile sha blobtype file r
 	reinject _ = return Nothing
 
+nukeIndex :: Repo -> IO ()
+nukeIndex r = nukeFile (localGitDir r </> "index")
+
 newtype GoodCommits = GoodCommits (S.Set Sha)
 
 emptyGoodCommits :: GoodCommits
@@ -432,39 +407,88 @@ displayList items header
 		| numitems > 10 = take 10 items ++ ["(and " ++ show (numitems - 10) ++ " more)"]
 		| otherwise = items
 
+{- Fix problems that would prevent repair from working at all
+ -
+ - A missing or corrupt .git/HEAD makes git not treat the repository as a
+ - git repo. If there is a git repo in a parent directory, it may move up
+ - the tree and use that one instead. So, cannot use `git show-ref HEAD` to
+ - test it.
+ -
+ - Explode the packed refs file, to simplify dealing with refs, and because
+ - fsck can complain about bad refs in it.
+ -}
+preRepair :: Repo -> IO ()
+preRepair g = do
+	unlessM (validhead <$> catchDefaultIO "" (safeReadFile headfile)) $ do
+		nukeFile headfile
+		writeFile headfile "ref: refs/heads/master"
+	explodePackedRefsFile g
+  where
+	headfile = localGitDir g </> "HEAD"
+	validhead s = "ref: refs/" `isPrefixOf` s || isJust (extractSha s)
+
 {- Put it all together. -}
 runRepair :: Bool -> Repo -> IO (Bool, MissingObjects, [Branch])
 runRepair forced g = do
+	preRepair g
 	putStrLn "Running git fsck ..."
 	fsckresult <- findBroken False g
 	if foundBroken fsckresult
-		then runRepairOf fsckresult forced Nothing g
+		then runRepair' fsckresult forced Nothing g
 		else do
 			putStrLn "No problems found."
 			return (True, S.empty, [])
 
 runRepairOf :: FsckResults -> Bool -> Maybe FilePath -> Repo -> IO (Bool, MissingObjects, [Branch])
 runRepairOf fsckresult forced referencerepo g = do
+	preRepair g
+	runRepair' fsckresult forced referencerepo g
+
+runRepair' :: FsckResults -> Bool -> Maybe FilePath -> Repo -> IO (Bool, MissingObjects, [Branch])
+runRepair' fsckresult forced referencerepo g = do
 	missing <- cleanCorruptObjects fsckresult g
 	stillmissing <- retrieveMissingObjects missing referencerepo g
-	if S.null stillmissing
+	case stillmissing of
-		then successfulfinish stillmissing []
+		Just s
+			| S.null s -> if repoIsLocalBare g
+				then successfulfinish S.empty []
+				else ifM (checkIndex S.empty g)
+					( successfulfinish s []
+					, do
+						putStrLn "No missing objects found, but the index file is corrupt!"
+						if forced
+							then corruptedindex
+							else needforce S.empty
+					)
+			| otherwise -> if forced
+				then ifM (checkIndex s g)
+					( continuerepairs s
+					, corruptedindex
+					)
 				else do
 					putStrLn $ unwords
-				[ show (S.size stillmissing)
+						[ show (S.size s)
 						, "missing objects could not be recovered!"
 						]
-			if forced
+					unsuccessfulfinish s
-				then continuerepairs stillmissing
+		Nothing
-				else unsuccessfulfinish stillmissing
+			| forced -> ifM (pure (repoIsLocalBare g) <||> checkIndex S.empty g)
+				( do
+					missing' <- cleanCorruptObjects Nothing g
+					case missing' of
+						Nothing -> return (False, S.empty, [])
+						Just stillmissing' -> continuerepairs stillmissing'
+				, corruptedindex
+				)
+			| otherwise -> unsuccessfulfinish S.empty
   where
 	continuerepairs stillmissing = do
 		(remotebranches, goodcommits) <- removeTrackingBranches stillmissing emptyGoodCommits g
 		unless (null remotebranches) $
 			putStrLn $ unwords
-				[ "removed"
+				[ "Removed"
 				, show (length remotebranches)
-				, "remote tracking branches that referred to missing objects"
+				, "remote tracking branches that referred to missing objects."
 				]
 		(resetbranches, deletedbranches, _) <- resetLocalBranches stillmissing goodcommits g
 		displayList (map show resetbranches)
@@ -491,17 +515,37 @@ runRepairOf fsckresult forced referencerepo g = do
 				putStrLn "Successfully recovered repository!"
 				putStrLn "Please carefully check that the changes mentioned above are ok.."
 				return (True, stillmissing, modifiedbranches)
+	
+	corruptedindex = do
+		nukeIndex g
+		-- The corrupted index can prevent fsck from finding other
+		-- problems, so re-run repair.
+		fsckresult' <- findBroken False g
+		result <- runRepairOf fsckresult' forced referencerepo g
+		putStrLn "Removed the corrupted index file. You should look at what files are present in your working tree and git add them back to the index when appropriate."
+		return result
+
 	successfulfinish stillmissing modifiedbranches = do
 		mapM_ putStrLn
 			[ "Successfully recovered repository!"
-			, "You should run \"git fsck\" to make sure, but it looks like"
+			, "You should run \"git fsck\" to make sure, but it looks like everything was recovered ok."
-			, "everything was recovered ok."
 			]
 		return (True, stillmissing, modifiedbranches)
 	unsuccessfulfinish stillmissing = do
 		if repoIsLocalBare g
 			then do
-				putStrLn "If you have a clone of this bare repository, you should add it as a remote of this repository, and re-run git-recover-repository."
+				putStrLn "If you have a clone of this bare repository, you should add it as a remote of this repository, and retry."
-				putStrLn "If there are no clones of this repository, you can instead run git-recover-repository with the --force parameter to force recovery to a possibly usable state."
+				putStrLn "If there are no clones of this repository, you can instead retry with the --force parameter to force recovery to a possibly usable state."
-			else putStrLn "To force a recovery to a usable state, run this command again with the --force parameter."
 				return (False, stillmissing, [])
+			else needforce stillmissing
+	needforce stillmissing = do
+		putStrLn "To force a recovery to a usable state, retry with the --force parameter."
+		return (False, stillmissing, [])
+
+successfulRepair :: (Bool, MissingObjects, [Branch]) -> Bool
+successfulRepair = fst3
+
+safeReadFile :: FilePath -> IO String
+safeReadFile f = do
+	allowRead f
+	readFileStrictAnyEncoding f

Git/Types.hs

@@ -10,6 +10,7 @@ module Git.Types where
 import Network.URI
 import qualified Data.Map as M
 import System.Posix.Types
+import Utility.SafeCommand
 
 {- Support repositories on local disk, and repositories accessed via an URL.
  -
@@ -35,11 +36,15 @@ data Repo = Repo
 	, fullconfig :: M.Map String [String]
 	, remotes :: [Repo]
 	-- remoteName holds the name used for this repo in remotes
-	, remoteName :: Maybe String
+	, remoteName :: Maybe RemoteName
 	-- alternate environment to use when running git commands
 	, gitEnv :: Maybe [(String, String)]
+	-- global options to pass to git when running git commands
+	, gitGlobalOpts :: [CommandParam]
 	} deriving (Show, Eq)
 
+type RemoteName = String
+
 {- A git ref. Can be a sha1, or a branch or tag name. -}
 newtype Ref = Ref String
 	deriving (Eq, Ord)

Git/Url.hs

@@ -37,32 +37,33 @@ uriRegName' a = fixup $ uriRegName a
 	fixup x = x
 
 {- Hostname of an URL repo. -}
-host :: Repo -> String
+host :: Repo -> Maybe String
 host = authpart uriRegName'
 
 {- Port of an URL repo, if it has a nonstandard one. -}
 port :: Repo -> Maybe Integer
 port r = 
 	case authpart uriPort r of
-		":" -> Nothing
+		Nothing -> Nothing
-		(':':p) -> readish p
+		Just ":" -> Nothing
-		_ -> Nothing
+		Just (':':p) -> readish p
+		Just _ -> Nothing
 
 {- Hostname of an URL repo, including any username (ie, "user@host") -}
-hostuser :: Repo -> String
+hostuser :: Repo -> Maybe String
-hostuser r = authpart uriUserInfo r ++ authpart uriRegName' r
+hostuser r = (++)
+	<$> authpart uriUserInfo r
+	<*> authpart uriRegName' r
 
 {- The full authority portion an URL repo. (ie, "user@host:port") -}
-authority :: Repo -> String
+authority :: Repo -> Maybe String
 authority = authpart assemble
   where
 	assemble a = uriUserInfo a ++ uriRegName' a ++ uriPort a
 
 {- Applies a function to extract part of the uriAuthority of an URL repo. -}
-authpart :: (URIAuth -> a) -> Repo -> a
+authpart :: (URIAuth -> a) -> Repo -> Maybe a
-authpart a Repo { location = Url u } = a auth
+authpart a Repo { location = Url u } = a <$> uriAuthority u
-  where
-	auth = fromMaybe (error $ "bad url " ++ show u) (uriAuthority u)
 authpart _ repo = notUrl repo
 
 notUrl :: Repo -> a

GitAnnex.hs

@@ -5,7 +5,7 @@
  - Licensed under the GNU GPL version 3 or higher.
  -}
 
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP, OverloadedStrings #-}
 
 module GitAnnex where
 
@@ -46,6 +46,7 @@ import qualified Command.Whereis
 import qualified Command.List
 import qualified Command.Log
 import qualified Command.Merge
+import qualified Command.Info
 import qualified Command.Status
 import qualified Command.Migrate
 import qualified Command.Uninit
@@ -87,6 +88,9 @@ import qualified Command.XMPPGit
 import qualified Command.Test
 import qualified Command.FuzzTest
 #endif
+#ifdef WITH_EKG
+import System.Remote.Monitoring
+#endif
 
 cmds :: [Command]
 cmds = concat
@@ -140,6 +144,7 @@ cmds = concat
 	, Command.List.def
 	, Command.Log.def
 	, Command.Merge.def
+	, Command.Info.def
 	, Command.Status.def
 	, Command.Migrate.def
 	, Command.Map.def
@@ -169,4 +174,8 @@ header :: String
 header = "git-annex command [option ...]"
 
 run :: [String] -> IO ()
-run args = dispatch True args cmds options [] header Git.CurrentRepo.get
+run args = do
+#ifdef WITH_EKG
+	_ <- forkServer "localhost" 4242
+#endif
+	dispatch True args cmds options [] header Git.CurrentRepo.get