tagging version 4.20130802

-----BEGIN PGP SIGNATURE-----
 Version: GnuPG v1.4.12 (GNU/Linux)
 
 iQIVAwUAUfvuiskQ2SIlEuPHAQhMtRAArjO6f20PXrrfOqiA0X322BPeA7LZ1Fqk
 jF6npxtLPE/ZqL+fJ7lC2pjBomqYYr1d9eTTQm5+L+6YYBu3ICFFNYkEefpLrj7N
 JYQsw9WFcJ+c7q3CVw7HtDwJlZ8g/NrZsOLAtNrsDiS6edpY5YBN67R7fKu5f2CY
 0dAbSAGo16ViEpPRaJZ+lIJyqxy8VTvMy82Zi+90o//Iu4Abz/BfycVXEXapxL3g
 GRmcVYW3eY6Kwu/GGlzhcuseKUu7PA8RqCSNyPmihpCB2xPJ2EEiAUYQhLSE0k3L
 aYxpTi0rXVhRV7Ht5AsfBKs5u6gdpsic18M7Wn9E6+L0P0NTYdF+rjj3YmLaYx7Y
 jFcKDzHUad8GwsrbHfHBnbI546yLfu9b3pvEDgZ+JTw/YLKcDqFA1cvp8E/Kfi/x
 rZxU9cyBnWd+gksJp93QfhLjxXUDfc5f1dNJ1/W13/kozPkrHTvVNNLosvR80+gE
 /KH5N2WiQsK0FYuKXCNVvW5EfQ0H8fUYc3rXcTpSawOVWfstmGsLLQWxeeK+NsEW
 B0ktmLXku7wbWeVnDgZ9WP8/NrbU2MoPry6Pvlpbh8SEpd+22fESJr+tiSv9ZwsK
 3JaF51uDo24bDoMkc9w7nPMApJUo45aBry5GP2Z3/yj29NsroXnsAW68AOkCkCaL
 aBLNp754fD8=
 =Qtd1
 -----END PGP SIGNATURE-----

Merge tag '4.20130802' into debian-wheezy-backport

Conflicts:
	debian/control

.gitignore

@@ -13,8 +13,6 @@ git-union-merge.1
 doc/.ikiwiki
 html
 *.tix
-*.o
-*.hi
 .hpc
 dist
 # Sandboxed builds
@@ -26,3 +24,5 @@ cabal-dev
 .virthualenv
 tags
 Setup
+*.hi
+*.o

Annex.hs

@@ -10,7 +10,6 @@
 module Annex (
 	Annex,
 	AnnexState(..),
-	FileInfo(..),
 	PreferredContentMap,
 	new,
 	newState,
@@ -55,6 +54,7 @@ import Types.TrustLevel
 import Types.Group
 import Types.Messages
 import Types.UUID
+import Types.FileMatcher
 import qualified Utility.Matcher
 import qualified Data.Map as M
 import qualified Data.Set as S
@@ -74,12 +74,6 @@ newtype Annex a = Annex { runAnnex :: ReaderT (MVar AnnexState) IO a }
 	)
 
 type Matcher a = Either [Utility.Matcher.Token a] (Utility.Matcher.Matcher a)
-
-data FileInfo = FileInfo
-	{ relFile :: FilePath -- may be relative to cwd
-	, matchFile :: FilePath -- filepath to match on; may be relative to top
-	}
-
 type PreferredContentMap = M.Map UUID (Utility.Matcher.Matcher (S.Set UUID -> FileInfo -> Annex Bool))
 
 -- internal state storage
@@ -92,11 +86,13 @@ data AnnexState = AnnexState
 	, force :: Bool
 	, fast :: Bool
 	, auto :: Bool
+	, daemon :: Bool
 	, branchstate :: BranchState
 	, repoqueue :: Maybe Git.Queue.Queue
 	, catfilehandles :: M.Map FilePath CatFileHandle
 	, checkattrhandle :: Maybe CheckAttrHandle
 	, forcebackend :: Maybe String
+	, forcenumcopies :: Maybe Int
 	, limit :: Matcher (FileInfo -> Annex Bool)
 	, uuidmap :: Maybe UUIDMap
 	, preferredcontentmap :: Maybe PreferredContentMap
@@ -122,11 +118,13 @@ newState gitrepo = AnnexState
 	, force = False
 	, fast = False
 	, auto = False
+	, daemon = False
 	, branchstate = startBranchState
 	, repoqueue = Nothing
 	, catfilehandles = M.empty
 	, checkattrhandle = Nothing
 	, forcebackend = Nothing
+	, forcenumcopies = Nothing
 	, limit = Left []
 	, uuidmap = Nothing
 	, preferredcontentmap = Nothing

Annex/Branch.hs

@@ -21,6 +21,7 @@ module Annex.Branch (
 	change,
 	commit,
 	files,
+	withIndex,
 ) where
 
 import qualified Data.ByteString.Lazy.Char8 as L
@@ -65,7 +66,7 @@ hasSibling = not . null <$> siblingBranches
 {- List of git-annex (refs, branches), including the main one and any
  - from remotes. Duplicate refs are filtered out. -}
 siblingBranches :: Annex [(Git.Ref, Git.Branch)]
-siblingBranches = inRepo $ Git.Ref.matchingUniq name
+siblingBranches = inRepo $ Git.Ref.matchingUniq [name]
 
 {- Creates the branch, if it does not already exist. -}
 create :: Annex ()

Annex/CatFile.hs

@@ -57,15 +57,36 @@ catFileHandle = do
 {- From the Sha or Ref of a symlink back to the key. -}
 catKey :: Ref -> Annex (Maybe Key)
 catKey ref = do
-	l <- fromInternalGitPath . encodeW8 . L.unpack  <$> catObject ref
+	l <- fromInternalGitPath . encodeW8 . L.unpack <$> catObject ref
 	return $ if isLinkToAnnex l
 		then fileKey $ takeFileName l
 		else Nothing
 
-{- From a file in git back to the key.
+{- 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
+ - does not refresh the index file after it's started up, so things
+ - newly staged in the index won't show up. It does, however, notice
+ - when branches change.
+ -
+ - For command-line git-annex use, that doesn't matter. It's perfectly
+ - reasonable for things staged in the index after the currently running
+ - git-annex process to not be noticed by it.
+ -
+ - For the assistant, this is much more of a problem, since it commits
+ - files and then needs to be able to immediately look up their keys.
+ - OTOH, the assistant doesn't keep changes staged in the index for very
+ - long at all before committing them -- and it won't look at the keys
+ - of files until after committing them.
+ -
+ - So, this gets info from the index, unless running as a daemon.
  -}
 catKeyFile :: FilePath -> Annex (Maybe Key)
-catKeyFile f = catKey $ Ref $ ":./" ++ f
+catKeyFile f = ifM (Annex.getState Annex.daemon)
+	( catKey $ Ref $ "HEAD:./" ++ f
+	, catKey $ Ref $ ":./" ++ f
+	)

Annex/Content.hs

@@ -1,6 +1,6 @@
 {- git-annex file content managing
  -
- - Copyright 2010,2012 Joey Hess <joey@kitenet.net>
+ - Copyright 2010-2013 Joey Hess <joey@kitenet.net>
  -
  - Licensed under the GNU GPL version 3 or higher.
  -}
@@ -10,6 +10,7 @@
 module Annex.Content (
 	inAnnex,
 	inAnnexSafe,
+	inAnnexCheck,
 	lockContent,
 	getViaTmp,
 	getViaTmpChecked,
@@ -56,7 +57,11 @@ import Annex.ReplaceFile
 
 {- Checks if a given key's content is currently present. -}
 inAnnex :: Key -> Annex Bool
-inAnnex = inAnnex' id False $ liftIO . doesFileExist
+inAnnex key = inAnnexCheck key $ liftIO . doesFileExist
+
+{- Runs an arbitrary check on a key's content. -}
+inAnnexCheck :: Key -> (FilePath -> Annex Bool) -> Annex Bool
+inAnnexCheck key check = inAnnex' id False check key
 
 {- Generic inAnnex, handling both indirect and direct mode.
  -
@@ -87,14 +92,14 @@ inAnnexSafe = inAnnex' (fromMaybe False) (Just False) go
   where
 	go f = liftIO $ openforlock f >>= check
 	openforlock f = catchMaybeIO $
-#ifndef __WINDOWS__
+#ifndef mingw32_HOST_OS
 		openFd f ReadOnly Nothing defaultFileFlags
 #else
 		return ()
 #endif
 	check Nothing = return is_missing
 	check (Just h) = do
-#ifndef __WINDOWS__
+#ifndef mingw32_HOST_OS
 		v <- getLock h (ReadLock, AbsoluteSeek, 0, 0)
 		closeFd h
 		return $ case v of
@@ -111,11 +116,11 @@ inAnnexSafe = inAnnex' (fromMaybe False) (Just False) go
  - it. (If the content is not present, no locking is done.) -}
 lockContent :: Key -> Annex a -> Annex a
 lockContent key a = do
-#ifdef __WINDOWS__
+#ifdef mingw32_HOST_OS
 	a
 #else
 	file <- calcRepo $ gitAnnexLocation key
-	bracketIO (openforlock file >>= lock) unlock a
+	bracketIO (openforlock file >>= lock) unlock (const a)
   where
 	{- Since files are stored with the write bit disabled, have
 	 - to fiddle with permissions to open for an exclusive lock. -}
@@ -205,8 +210,7 @@ checkDiskSpace destination key alreadythere = do
 	case (free, keySize key) of
 		(Just have, Just need) -> do
 			let ok = (need + reserve <= have + alreadythere) || force
-			unless ok $ do
+			unless ok $
-				liftIO $ print (need, reserve, have, alreadythere)
 				needmorespace (need + reserve - have - alreadythere)
 			return ok
 		_ -> return True

Annex/Content/Direct.hs

@@ -7,6 +7,7 @@
 
 module Annex.Content.Direct (
 	associatedFiles,
+	associatedFilesRelative,
 	removeAssociatedFile,
 	removeAssociatedFileUnchecked,
 	addAssociatedFile,
@@ -193,7 +194,7 @@ compareInodeCachesWith :: Annex InodeComparisonType
 compareInodeCachesWith = ifM inodesChanged ( return Weakly, return Strongly )
 
 {- Copies the contentfile to the associated file, if the associated
- - file has not content. If the associated file does have content,
+ - file has no content. If the associated file does have content,
  - even if the content differs, it's left unchanged. -}
 addContentWhenNotPresent :: Key -> FilePath -> FilePath -> Annex ()
 addContentWhenNotPresent key contentfile associatedfile = do
@@ -232,6 +233,7 @@ readInodeSentinalFile = do
 writeInodeSentinalFile :: Annex ()
 writeInodeSentinalFile = do
 	sentinalfile <- fromRepo gitAnnexInodeSentinal
+	createAnnexDirectory (parentDir sentinalfile)
 	sentinalcachefile <- fromRepo gitAnnexInodeSentinalCache
 	liftIO $ writeFile sentinalfile ""
 	liftIO $ maybe noop (writeFile sentinalcachefile . showInodeCache)

Annex/Direct.hs

@@ -27,6 +27,7 @@ import Utility.InodeCache
 import Utility.CopyFile
 import Annex.Perms
 import Annex.ReplaceFile
+import Annex.Exception
 
 {- Uses git ls-files to find files that need to be committed, and stages
  - them into the index. Returns True if some changes were staged. -}
@@ -34,7 +35,7 @@ stageDirect :: Annex Bool
 stageDirect = do
 	Annex.Queue.flush
 	top <- fromRepo Git.repoPath
-	(l, cleanup) <- inRepo $ Git.LsFiles.stagedDetails [top]
+	(l, cleanup) <- inRepo $ Git.LsFiles.stagedOthersDetails [top]
 	forM_ l go
 	void $ liftIO cleanup
 	staged <- Annex.Queue.size
@@ -139,8 +140,10 @@ mergeDirectCleanup d oldsha newsha = do
 	liftIO $ removeDirectoryRecursive d
   where
 	updated item = do
-		go DiffTree.srcsha DiffTree.srcmode moveout moveout_raw
+		void $ tryAnnex $
-		go DiffTree.dstsha DiffTree.dstmode movein movein_raw
+			go DiffTree.srcsha DiffTree.srcmode moveout moveout_raw
+		void $ tryAnnex $ 
+			go DiffTree.dstsha DiffTree.dstmode movein movein_raw
 	  where
 		go getsha getmode a araw
 			| getsha item == nullSha = noop
@@ -173,7 +176,8 @@ mergeDirectCleanup d oldsha newsha = do
 		void $ tryIO $ rename (d </> f) f
 
 {- If possible, converts a symlink in the working tree into a direct
- - mode file. -}
+ - mode file. If the content is not available, leaves the symlink
+ - unchanged. -}
 toDirect :: Key -> FilePath -> Annex ()
 toDirect k f = fromMaybe noop =<< toDirectGen k f
 
@@ -181,28 +185,29 @@ toDirectGen :: Key -> FilePath -> Annex (Maybe (Annex ()))
 toDirectGen k f = do
 	loc <- calcRepo $ gitAnnexLocation k
 	ifM (liftIO $ doesFileExist loc)
-		( fromindirect loc
+		( return $ Just $ fromindirect loc
-		, fromdirect
+		, do
+			{- Copy content from another direct file. -}
+			absf <- liftIO $ absPath f
+			dlocs <- filterM (goodContent k) =<<
+				filterM (\l -> isNothing <$> getAnnexLinkTarget l) =<<
+				(filter (/= absf) <$> addAssociatedFile k f)
+			case dlocs of
+				[] -> return Nothing
+				(dloc:_) -> return $ Just $ fromdirect dloc
 		)
   where
-  	fromindirect loc = return $ Just $ do
+  	fromindirect loc = do
 		{- Move content from annex to direct file. -}
 		thawContentDir loc
 		updateInodeCache k loc
 		void $ addAssociatedFile k f
 		thawContent loc
 		replaceFile f $ liftIO . moveFile loc
-	fromdirect = do
+	fromdirect loc = do
-		{- Copy content from another direct file. -}
+		replaceFile f $
-		absf <- liftIO $ absPath f
+			liftIO . void . copyFileExternal loc
-		locs <- filterM (\loc -> isNothing <$> getAnnexLinkTarget loc) =<<
+		updateInodeCache k f
-			(filter (/= absf) <$> addAssociatedFile k f)
-		case locs of
-			(loc:_) -> return $ Just $ do
-				replaceFile f $
-					liftIO . void . copyFileExternal loc
-				updateInodeCache k f
-			_ -> return Nothing
 
 {- Removes a direct mode file, while retaining its content in the annex
  - (unless its content has already been changed). -}

Annex/Environment.hs

@@ -13,10 +13,19 @@ import Common.Annex
 import Utility.Env
 import Utility.UserInfo
 import qualified Git.Config
+import Config
+import Annex.Exception
 
 {- Checks that the system's environment allows git to function.
  - Git requires a GECOS username, or suitable git configuration, or
- - environment variables. -}
+ - environment variables.
+ -
+ - Git also requires the system have a hostname containing a dot.
+ - Otherwise, it tries various methods to find a FQDN, and will fail if it
+ - does not. To avoid replicating that code here, which would break if its
+ - methods change, this function does not check the hostname is valid.
+ - Instead, code that commits can use ensureCommit.
+ -}
 checkEnvironment :: Annex ()
 checkEnvironment = do
 	gitusername <- fromRepo $ Git.Config.getMaybe "user.name"
@@ -25,7 +34,7 @@ checkEnvironment = do
 
 checkEnvironmentIO :: IO ()
 checkEnvironmentIO =
-#ifdef __WINDOWS__
+#ifdef mingw32_HOST_OS
 	noop
 #else
 	whenM (null <$> myUserGecos) $ do
@@ -42,3 +51,12 @@ checkEnvironmentIO =
 	ensureEnv _ _ = noop
 #endif
 #endif
+
+{- Runs an action that commits to the repository, and if it fails, 
+ - sets user.email to a dummy value and tries the action again. -}
+ensureCommit :: Annex a -> Annex a
+ensureCommit a = either retry return =<< tryAnnex a 
+  where
+  	retry _ = do
+		setConfig (ConfigKey "user.email") =<< liftIO myUserName
+		a

Annex/Exception.hs

@@ -13,25 +13,27 @@
 module Annex.Exception (
 	bracketIO,
 	tryAnnex,
-	throw,
+	throwAnnex,
 	catchAnnex,
 ) where
 
-import Prelude hiding (catch)
+import qualified "MonadCatchIO-transformers" Control.Monad.CatchIO as M
-import "MonadCatchIO-transformers" Control.Monad.CatchIO (bracket, try, throw, catch)
+import Control.Exception
-import Control.Exception hiding (handle, try, throw, bracket, catch)
 
 import Common.Annex
 
 {- Runs an Annex action, with setup and cleanup both in the IO monad. -}
-bracketIO :: IO c -> (c -> IO b) -> Annex a -> Annex a
+bracketIO :: IO v -> (v -> IO b) -> (v -> Annex a) -> Annex a
-bracketIO setup cleanup go =
+bracketIO setup cleanup go = M.bracket (liftIO setup) (liftIO . cleanup) go
-	bracket (liftIO setup) (liftIO . cleanup) (const go)
 
 {- try in the Annex monad -}
 tryAnnex :: Annex a -> Annex (Either SomeException a)
-tryAnnex = try
+tryAnnex = M.try
+
+{- throw in the Annex monad -}
+throwAnnex :: Exception e => e -> Annex a
+throwAnnex = M.throw
 
 {- catch in the Annex monad -}
 catchAnnex :: Exception e => Annex a -> (e -> Annex a) -> Annex a
-catchAnnex = catch
+catchAnnex = M.catch

Annex/FileMatcher.hs

@@ -17,6 +17,7 @@ import Logs.Group
 import Logs.Remote
 import Annex.UUID
 import qualified Annex
+import Types.FileMatcher
 import Git.FilePath
 import Types.Remote (RemoteConfig)
 
@@ -33,9 +34,9 @@ checkFileMatcher' matcher file notpresent def
 	| isEmpty matcher = return def
 	| otherwise = do
 		matchfile <- getTopFilePath <$> inRepo (toTopFilePath file)
-		let fi = Annex.FileInfo
+		let fi = FileInfo
-			{ Annex.matchFile = matchfile
+			{ matchFile = matchfile
-			, Annex.relFile = file
+			, relFile = file
 			}
 		matchMrun matcher $ \a -> a notpresent fi
 

Annex/Journal.hs

@@ -84,10 +84,10 @@ lockJournal a = do
 	lockfile <- fromRepo gitAnnexJournalLock
 	createAnnexDirectory $ takeDirectory lockfile
 	mode <- annexFileMode
-	bracketIO (lock lockfile mode) unlock a
+	bracketIO (lock lockfile mode) unlock (const a)
   where
 	lock lockfile mode = do
-#ifndef __WINDOWS__
+#ifndef mingw32_HOST_OS
 		l <- noUmask mode $ createFile lockfile mode
 		waitToSetLock l (WriteLock, AbsoluteSeek, 0, 0)
 		return l
@@ -95,7 +95,7 @@ lockJournal a = do
 		writeFile lockfile ""
 		return lockfile
 #endif
-#ifndef __WINDOWS__
+#ifndef mingw32_HOST_OS
 	unlock = closeFd
 #else
 	unlock = removeFile

Annex/Link.hs

@@ -29,17 +29,19 @@ isAnnexLink file = maybe Nothing (fileKey . takeFileName) <$> getAnnexLinkTarget
 {- Gets the link target of a symlink.
  -
  - On a filesystem that does not support symlinks, fall back to getting the
- - link target by looking inside the file. (Only return at first 8k of the
+ - link target by looking inside the file.
- - file, more than enough for any symlink target.)
  -
  - Returns Nothing if the file is not a symlink, or not a link to annex
  - content.
  -}
 getAnnexLinkTarget :: FilePath -> Annex (Maybe LinkTarget)
-getAnnexLinkTarget file =
+getAnnexLinkTarget file = ifM (coreSymlinks <$> Annex.getGitConfig)
-	check readSymbolicLink $
+	( check readSymbolicLink $
-		check readfilestart $
+		return Nothing
+	, check readSymbolicLink $
+		check probefilecontent $
 			return Nothing
+	)
   where
 	check getlinktarget fallback = do
 		v <- liftIO $ catchMaybeIO $ getlinktarget file
@@ -49,10 +51,26 @@ getAnnexLinkTarget file =
 				| otherwise -> return Nothing
 			Nothing -> fallback
 
-	readfilestart f = do
+	probefilecontent f = do
 		h <- openFile f ReadMode
 		fileEncoding h
-		take 8192 <$> hGetContents h
+		-- The first 8k is more than enough to read; link
+		-- files are small.
+		s <- take 8192 <$> hGetContents h
+		-- If we got the full 8k, the file is too large
+		if length s == 8192
+			then do
+				hClose h
+				return ""
+			else do
+				hClose h
+				-- If there are any NUL or newline
+				-- characters, or whitespace, we
+				-- certianly don't have a link to a
+				-- git-annex key.
+				if any (`elem` s) "\0\n\r \t"
+					then return ""
+					else return s
 
 {- Creates a link on disk.
  -

Annex/LockPool.hs

@@ -22,7 +22,7 @@ lockFile file = go =<< fromPool file
   where
 	go (Just _) = noop -- already locked
 	go Nothing = do
-#ifndef __WINDOWS__
+#ifndef mingw32_HOST_OS
 		mode <- annexFileMode
 		fd <- liftIO $ noUmask mode $
 			openFd file ReadOnly (Just mode) defaultFileFlags
@@ -37,7 +37,7 @@ unlockFile :: FilePath -> Annex ()
 unlockFile file = maybe noop go =<< fromPool file
   where
 	go fd = do
-#ifndef __WINDOWS__
+#ifndef mingw32_HOST_OS
 		liftIO $ closeFd fd
 #endif
 		changePool $ M.delete file

Annex/ReplaceFile.hs

@@ -9,27 +9,31 @@ module Annex.ReplaceFile where
 
 import Common.Annex
 import Annex.Perms
+import Annex.Exception
 
 {- Replaces a possibly already existing file with a new version, 
  - atomically, by running an action.
  - 
  - The action is passed a temp file, which it can write to, and once
  - done the temp file is moved into place.
+ -
+ - The action can throw an IO exception, in which case the temp file
+ - will be deleted, and the existing file will be preserved.
+ -
+ - Throws an IO exception when it was unable to replace the file.
  -}
 replaceFile :: FilePath -> (FilePath -> Annex ()) -> Annex ()
 replaceFile file a = do
 	tmpdir <- fromRepo gitAnnexTmpDir
-	createAnnexDirectory tmpdir
+	void $ createAnnexDirectory tmpdir
-	tmpfile <- liftIO $ do
+	bracketIO (setup tmpdir) nukeFile $ \tmpfile -> do
-		(tmpfile, h) <- openTempFileWithDefaultPermissions tmpdir $
+		a tmpfile
-			takeFileName file
+		liftIO $ catchIO (rename tmpfile file) (fallback tmpfile)
+  where
+  	setup tmpdir = do
+		(tmpfile, h) <- openTempFileWithDefaultPermissions tmpdir "tmp"
 		hClose h
 		return tmpfile
-	a tmpfile
+	fallback tmpfile _ = do
-	liftIO $ do
+		createDirectoryIfMissing True $ parentDir file
-		r <- tryIO $ rename tmpfile file
+		rename tmpfile file
-		case r of
-			Left _ -> do
-				createDirectoryIfMissing True $ parentDir file
-				rename tmpfile file
-			_ -> noop

Annex/Ssh.hs

@@ -15,6 +15,7 @@ module Annex.Ssh (
 ) where
 
 import qualified Data.Map as M
+import Data.Hash.MD5
 
 import Common.Annex
 import Annex.LockPool
@@ -51,17 +52,18 @@ sshInfo (host, port) = go =<< sshCacheDir
 	go (Just dir) = do
 		let socketfile = dir </> hostport2socket host port
 		if valid_unix_socket_path socketfile
-			then return (Just socketfile, cacheparams socketfile)
+			then return (Just socketfile, sshConnectionCachingParams socketfile)
 			else do
 				socketfile' <- liftIO $ relPathCwdToFile socketfile
 				if valid_unix_socket_path socketfile'
-					then return (Just socketfile', cacheparams socketfile')
+					then return (Just socketfile', sshConnectionCachingParams socketfile')
 					else return (Nothing, [])
-	cacheparams :: FilePath -> [CommandParam]
+
-	cacheparams socketfile =
+sshConnectionCachingParams :: FilePath -> [CommandParam]
-		[ Param "-S", Param socketfile
+sshConnectionCachingParams socketfile = 
-		, Params "-o ControlMaster=auto -o ControlPersist=yes"
+	[ Param "-S", Param socketfile
-		]
+	, Params "-o ControlMaster=auto -o ControlPersist=yes"
+	]
 
 {- ssh connection caching creates sockets, so will not work on a
  - crippled filesystem. A GIT_ANNEX_TMP_DIR can be provided to use
@@ -96,7 +98,7 @@ sshCleanup = go =<< sshCacheDir
 			liftIO (catchDefaultIO [] $ dirContents dir)
 		forM_ sockets cleanup
 	cleanup socketfile = do
-#ifndef __WINDOWS__
+#ifndef mingw32_HOST_OS
 		-- Drop any shared lock we have, and take an
 		-- exclusive lock, without blocking. If the lock
 		-- succeeds, nothing is using this ssh, and it can
@@ -116,27 +118,27 @@ sshCleanup = go =<< sshCacheDir
 		stopssh socketfile
 #endif
 	stopssh socketfile = do
-		let (host, port) = socket2hostport socketfile
+		let params = sshConnectionCachingParams socketfile
-		(_, params) <- sshInfo (host, port)
 		-- "ssh -O stop" is noisy on stderr even with -q
 		void $ liftIO $ catchMaybeIO $
 			withQuietOutput createProcessSuccess $
 				proc "ssh" $ toCommand $
 					[ Params "-O stop"
-					] ++ params ++ [Param host]
+					] ++ params ++ [Param "any"]
 		-- Cannot remove the lock file; other processes may
 		-- be waiting on our exclusive lock to use it.
 
+{- This needs to be as short as possible, due to limitations on the length
+ - of the path to a socket file. At the same time, it needs to be unique
+ - for each host.
+ -}
 hostport2socket :: String -> Maybe Integer -> FilePath
-hostport2socket host Nothing = host
+hostport2socket host Nothing = hostport2socket' host
-hostport2socket host (Just port) = host ++ "!" ++ show port
+hostport2socket host (Just port) = hostport2socket' $ host ++ "!" ++ show port
-
+hostport2socket' :: String -> FilePath
-socket2hostport :: FilePath -> (String, Maybe Integer)
+hostport2socket' s
-socket2hostport socket
+	| length s > 32 = md5s (Str s)
-	| null p = (h, Nothing)
+	| otherwise = s
-	| otherwise = (h, readish p)
-  where
-	(h, p) = separate (== '!') $ takeFileName socket
 
 socket2lock :: FilePath -> FilePath
 socket2lock socket = socket ++ lockExt

Annex/Version.hs

@@ -25,7 +25,7 @@ supportedVersions :: [Version]
 supportedVersions = [defaultVersion, directModeVersion]
 
 upgradableVersions :: [Version]
-#ifndef __WINDOWS__
+#ifndef mingw32_HOST_OS
 upgradableVersions = ["0", "1", "2"]
 #else
 upgradableVersions = ["2"]

Annex/Wanted.hs

@@ -10,7 +10,6 @@ module Annex.Wanted where
 import Common.Annex
 import Logs.PreferredContent
 import Annex.UUID
-import Types.Remote
 
 import qualified Data.Set as S
 

Assistant.hs

@@ -1,126 +1,15 @@
 {- git-annex assistant daemon
  -
- - Copyright 2012 Joey Hess <joey@kitenet.net>
+ - Copyright 2012-2013 Joey Hess <joey@kitenet.net>
  -
  - Licensed under the GNU GPL version 3 or higher.
- -
- - Overview of threads and MVars, etc:
- -
- - Thread 1: parent
- - 	The initial thread run, double forks to background, starts other
- - 	threads, and then stops, waiting for them to terminate,
- - 	or for a ctrl-c.
- - Thread 2: Watcher
- - 	Notices new files, and calls handlers for events, queuing changes.
- - Thread 3: inotify internal
- - 	Used by haskell inotify library to ensure inotify event buffer is
- - 	kept drained.
- - Thread 4: inotify startup scanner
- - 	Scans the tree and registers inotify watches for each directory.
- -	A MVar lock is used to prevent other inotify handlers from running
- -	until this is complete.
- - Thread 5: Committer
- - 	Waits for changes to occur, and runs the git queue to update its
- - 	index, then commits. Also queues Transfer events to send added
- - 	files to other remotes.
- - Thread 6: Pusher
- - 	Waits for commits to be made, and pushes updated branches to remotes,
- - 	in parallel. (Forks a process for each git push.)
- - Thread 7: PushRetryer
- - 	Runs every 30 minutes when there are failed pushes, and retries
- - 	them.
- - Thread 8: Merger
- - 	Waits for pushes to be received from remotes, and merges the
- - 	updated branches into the current branch.
- - 	(This uses inotify on .git/refs/heads, so there are additional
- - 	inotify threads associated with it, too.)
- - Thread 9: TransferWatcher
- - 	Watches for transfer information files being created and removed,
- - 	and maintains the DaemonStatus currentTransfers map.
- - 	(This uses inotify on .git/annex/transfer/, so there are
- - 	additional inotify threads associated with it, too.)
- - Thread 10: TransferPoller
- -	Polls to determine how much of each ongoing transfer is complete.
- - Thread 11: Transferrer
- - 	Waits for Transfers to be queued and does them.
- - Thread 12: StatusLogger
- - 	Wakes up periodically and records the daemon's status to disk.
- - Thread 13: SanityChecker
- - 	Wakes up periodically (rarely) and does sanity checks.
- - Thread 14: MountWatcher
- - 	Either uses dbus to watch for drive mount events, or, when
- - 	there's no dbus, polls to find newly mounted filesystems.
- - 	Once a filesystem that contains a remote is mounted, updates
- - 	state about that remote, pulls from it, and queues a push to it,
- - 	as well as an update, and queues it onto the
- - 	ConnectedRemoteChan
- - Thread 15: NetWatcher
- - 	Deals with network connection interruptions, which would cause
- - 	transfers to fail, and can be recovered from by waiting for a
- - 	network connection, and syncing with all network remotes.
- - 	Uses dbus to watch for network connections, or when dbus
- - 	cannot be used, assumes there's been one every 30 minutes.
- - Thread 16: TransferScanner
- - 	Does potentially expensive checks to find data that needs to be
- - 	transferred from or to remotes, and queues Transfers.
- - 	Uses the ScanRemotes map.a
- - Thread 17: PairListener
- - 	Listens for incoming pairing traffic, and takes action.
- - Thread 18: ConfigMonitor
- - 	Triggered by changes to the git-annex branch, checks for changed
- - 	config files, and reloads configs.
- - Thread 19: XMPPClient
- - 	Built-in XMPP client.
- - Thread 20: WebApp
- - 	Spawns more threads as necessary to handle clients.
- - 	Displays the DaemonStatus.
- - Thread 21: Glacier
- - 	Deals with retrieving files from Amazon Glacier.
- -
- - ThreadState: (MVar)
- - 	The Annex state is stored here, which allows resuscitating the
- - 	Annex monad in IO actions run by the watcher and committer
- - 	threads. Thus, a single state is shared amoung the threads, and
- - 	only one at a time can access it.
- - DaemonStatusHandle: (STM TMVar)
- - 	The daemon's current status.
- - ChangeChan: (STM TChan)
- - 	Changes are indicated by writing to this channel. The committer
- - 	reads from it.
- - CommitChan: (STM TChan)
- - 	Commits are indicated by writing to this channel. The pusher reads
- - 	from it.
- - FailedPushMap (STM TMVar)
- - 	Failed pushes are indicated by writing to this TMVar. The push
- - 	retrier blocks until they're available.
- - TransferQueue (STM TChan)
- - 	Transfers to make are indicated by writing to this channel.
- - TransferSlots (QSemN)
- - 	Count of the number of currently available transfer slots.
- - 	Updated by the transfer watcher, this allows other threads
- - 	to block until a slot is available.
- - 	This MVar should only be manipulated from inside the Annex monad,
- - 	which ensures it's accessed only after the ThreadState MVar.
- - ScanRemotes (STM TMVar)
- - 	Remotes that have been disconnected, and should be scanned
- - 	are indicated by writing to this TMVar.
- - BranchChanged (STM SampleVar)
- - 	Changes to the git-annex branch are indicated by updating this
- - 	SampleVar.
- - NetMessager (STM TChan, TMVar, SampleVar)
- - 	Used to feed messages to the built-in XMPP client, handle
- - 	pushes, and signal it when it needs to restart due to configuration
- - 	or networking changes.
- - UrlRenderer (MVar)
- - 	A Yesod route rendering function is stored here. This allows
- - 	things that need to render Yesod routes to block until the webapp
- - 	has started up and such rendering is possible.
  -}
 
 {-# LANGUAGE CPP #-}
 
 module Assistant where
 
+import qualified Annex
 import Assistant.Common
 import Assistant.DaemonStatus
 import Assistant.NamedThread
@@ -149,6 +38,7 @@ import Assistant.Threads.PairListener
 #endif
 #ifdef WITH_XMPP
 import Assistant.Threads.XMPPClient
+import Assistant.Threads.XMPPPusher
 #endif
 #else
 #warning Building without the webapp. You probably need to install Yesod..
@@ -172,6 +62,7 @@ stopDaemon = liftIO . Utility.Daemon.stopDaemon =<< fromRepo gitAnnexPidFile
  - stdout and stderr descriptors. -}
 startDaemon :: Bool -> Bool -> Maybe HostName ->  Maybe (Maybe Handle -> Maybe Handle -> String -> FilePath -> IO ()) -> Annex ()
 startDaemon assistant foreground listenhost startbrowser = do
+	Annex.changeState $ \s -> s { Annex.daemon = True }
 	pidfile <- fromRepo gitAnnexPidFile
 	logfile <- fromRepo gitAnnexLogFile
 	logfd <- liftIO $ openLog logfile
@@ -223,6 +114,8 @@ startDaemon assistant foreground listenhost startbrowser = do
 #endif
 #ifdef WITH_XMPP
 			, assist $ xmppClientThread urlrenderer
+			, assist $ xmppSendPackThread urlrenderer
+			, assist $ xmppReceivePackThread urlrenderer
 #endif
 #endif
 			, assist $ pushThread

Assistant/Alert.hs

@@ -41,12 +41,16 @@ mkAlertButton label urlrenderer route = do
 		}
 #endif
 
+renderData :: Alert -> TenseText
+renderData = tenseWords . alertData
+
 baseActivityAlert :: Alert
 baseActivityAlert = Alert
 	{ alertClass = Activity
 	, alertHeader = Nothing
-	, alertMessageRender = tenseWords
+	, alertMessageRender = renderData
 	, alertData = []
+	, alertCounter = 0
 	, alertBlockDisplay = False
 	, alertClosable = False
 	, alertPriority = Medium
@@ -60,8 +64,9 @@ warningAlert :: String -> String -> Alert
 warningAlert name msg = Alert
 	{ alertClass = Warning
 	, alertHeader = Just $ tenseWords ["warning"]
-	, alertMessageRender = tenseWords
+	, alertMessageRender = renderData
 	, alertData = [UnTensed $ T.pack msg]
+	, alertCounter = 0
 	, alertBlockDisplay = True
 	, alertClosable = True
 	, alertPriority = High
@@ -128,6 +133,7 @@ sanityCheckFixAlert msg = Alert
 	, alertHeader = Just $ tenseWords ["Fixed a problem"]
 	, alertMessageRender = render
 	, alertData = [UnTensed $ T.pack msg]
+	, alertCounter = 0
 	, alertBlockDisplay = True
 	, alertPriority = High
 	, alertClosable = True
@@ -137,7 +143,7 @@ sanityCheckFixAlert msg = Alert
 	, alertButton = Nothing
 	}
   where
-	render dta = tenseWords $ alerthead : dta ++ [alertfoot]
+	render alert = tenseWords $ alerthead : alertData alert ++ [alertfoot]
 	alerthead = "The daily sanity check found and fixed a problem:"
 	alertfoot = "If these problems persist, consider filing a bug report."
 
@@ -152,8 +158,9 @@ pairRequestReceivedAlert :: String -> AlertButton -> Alert
 pairRequestReceivedAlert who button = Alert
 	{ alertClass = Message
 	, alertHeader = Nothing
-	, alertMessageRender = tenseWords
+	, alertMessageRender = renderData
 	, alertData = [UnTensed $ T.pack $ who ++ " is sending a pair request."]
+	, alertCounter = 0
 	, alertBlockDisplay = False
 	, alertPriority = High
 	, alertClosable = True
@@ -180,7 +187,8 @@ xmppNeededAlert button = Alert
 	, alertButton = Just button
 	, alertClosable = True
 	, alertClass = Message
-	, alertMessageRender = tenseWords
+	, alertMessageRender = renderData
+	, alertCounter = 0
 	, alertBlockDisplay = True
 	, alertName = Just $ XMPPNeededAlert
 	, alertCombiner = Just $ dataCombiner $ \_old new -> new
@@ -198,7 +206,8 @@ cloudRepoNeededAlert friendname button = Alert
 	, alertButton = Just button
 	, alertClosable = True
 	, alertClass = Message
-	, alertMessageRender = tenseWords
+	, alertMessageRender = renderData
+	, alertCounter = 0
 	, alertBlockDisplay = True
 	, alertName = Just $ CloudRepoNeededAlert
 	, alertCombiner = Just $ dataCombiner $ \_old new -> new
@@ -215,41 +224,80 @@ remoteRemovalAlert desc button = Alert
 	, alertButton = Just button
 	, alertClosable = True
 	, alertClass = Message
-	, alertMessageRender = tenseWords
+	, alertMessageRender = renderData
+	, alertCounter = 0
 	, alertBlockDisplay = True
 	, alertName = Just $ RemoteRemovalAlert desc
 	, alertCombiner = Just $ dataCombiner $ \_old new -> new
 	, alertData = []
 	}
 
-fileAlert :: TenseChunk -> FilePath -> Alert
+{- Show a message that relates to a list of files.
-fileAlert msg file = (activityAlert Nothing [f])
+ -
+ - The most recent several files are shown, and a count of any others. -}
+fileAlert :: TenseChunk -> [FilePath] -> Alert
+fileAlert msg files = (activityAlert Nothing shortfiles)
 	{ alertName = Just $ FileAlert msg
-	, alertMessageRender = render
+	, alertMessageRender = renderer
-	, alertCombiner = Just $ dataCombiner combiner
+	, alertCounter = counter
+	, alertCombiner = Just $ fullCombiner combiner
 	}
   where
-	f = fromString $ shortFile $ takeFileName file
+	maxfilesshown = 10
-	render fs = tenseWords $ msg : fs
-	combiner new old = take 10 $ new ++ old
 
-addFileAlert :: String -> Alert
+	(somefiles, counter) = splitcounter (dedupadjacent files)
+	shortfiles = map (fromString . shortFile . takeFileName) somefiles
+
+	renderer alert = tenseWords $ msg : alertData alert ++ showcounter
+	  where
+		showcounter = case alertCounter alert of
+			0 -> []
+			_ -> [fromString $ "and " ++ show (alertCounter alert) ++ " other files"]
+
+	dedupadjacent (x:y:rest)
+		| x == y = dedupadjacent (y:rest)
+		| otherwise = x : dedupadjacent (y:rest)
+	dedupadjacent (x:[]) = [x]
+	dedupadjacent [] = []
+
+	{- Note that this ensures the counter is never 1; no need to say 
+	 - "1 file" when the filename could be shown. -}
+	splitcounter l
+		| length l <= maxfilesshown = (l, 0)
+		| otherwise =
+			let (keep, rest) = splitAt (maxfilesshown - 1) l
+			in (keep, length rest)
+	
+	combiner new old =
+		let (fs, n) = splitcounter $
+			dedupadjacent $ alertData new ++ alertData old
+		    cnt = n + alertCounter new + alertCounter old
+		in old
+			{ alertData = fs
+			, alertCounter = cnt
+			}
+
+addFileAlert :: [FilePath] -> Alert
 addFileAlert = fileAlert (Tensed "Adding" "Added")
 
 {- This is only used as a success alert after a transfer, not during it. -}
 transferFileAlert :: Direction -> Bool -> FilePath -> Alert
-transferFileAlert direction True
+transferFileAlert direction True file
-	| direction == Upload = fileAlert "Uploaded"
+	| direction == Upload = fileAlert "Uploaded" [file]
-	| otherwise = fileAlert "Downloaded"
+	| otherwise = fileAlert "Downloaded" [file]
-transferFileAlert direction False
+transferFileAlert direction False file
-	| direction == Upload = fileAlert "Upload failed"
+	| direction == Upload = fileAlert "Upload failed" [file]
-	| otherwise = fileAlert "Download failed"
+	| otherwise = fileAlert "Download failed" [file]
 
 dataCombiner :: ([TenseChunk] -> [TenseChunk] -> [TenseChunk]) -> AlertCombiner
-dataCombiner combiner new old
+dataCombiner combiner = fullCombiner $
+	\new old -> old { alertData = alertData new `combiner` alertData old }
+
+fullCombiner :: (Alert -> Alert -> Alert) -> AlertCombiner
+fullCombiner combiner new old
 	| alertClass new /= alertClass old = Nothing
 	| alertName new == alertName old = 
-		Just $! old { alertData = alertData new `combiner` alertData old }
+		Just $! new `combiner` old
 	| otherwise = Nothing
 
 shortFile :: FilePath -> String

Assistant/Alert/Utility.hs

@@ -56,7 +56,7 @@ renderAlertHeader alert = renderTense (alertTense alert) <$> alertHeader alert
 {- Renders an alert's message for display. -}
 renderAlertMessage :: Alert -> Text
 renderAlertMessage alert = renderTense (alertTense alert) $
-	(alertMessageRender alert) (alertData alert)
+	(alertMessageRender alert) alert
 
 showAlert :: Alert -> String
 showAlert alert = T.unpack $ T.unwords $ catMaybes

Assistant/Drop.hs

@@ -11,13 +11,14 @@ import Assistant.Common
 import Assistant.DaemonStatus
 import Logs.Location
 import Logs.Trust
-import Types.Remote (AssociatedFile, uuid)
+import Types.Remote (uuid)
 import qualified Remote
 import qualified Command.Drop
 import Command
 import Annex.Wanted
 import Annex.Exception
 import Config
+import Annex.Content.Direct
 
 import qualified Data.Set as S
 
@@ -35,20 +36,30 @@ handleDrops reason fromhere key f knownpresentremote = do
 {- The UUIDs are ones where the content is believed to be present.
  - The Remote list can include other remotes that do not have the content;
  - only ones that match the UUIDs will be dropped from.
- - If allows to drop fromhere, that drop will be tried first. -}
+ - If allowed to drop fromhere, that drop will be tried first.
+ -
+ - In direct mode, all associated files are checked, and only if all
+ - of them are unwanted are they dropped.
+ -}
 handleDropsFrom :: [UUID] -> [Remote] -> Reason -> Bool -> Key -> AssociatedFile -> Maybe Remote -> Assistant ()
 handleDropsFrom _ _ _ _ _ Nothing _ = noop
-handleDropsFrom locs rs reason fromhere key (Just f) knownpresentremote
+handleDropsFrom locs rs reason fromhere key (Just afile) knownpresentremote = do
-	| fromhere = do
+	fs <- liftAnnex $ ifM isDirect
-		n <- getcopies
+		( do
-		if checkcopies n Nothing
+			l <- associatedFilesRelative key
-			then go rs =<< dropl n
+			if null l
-			else go rs n
+				then return [afile]
-	| otherwise = go rs =<< getcopies
+				else return l
+		, return [afile]
+		)
+	n <- getcopies fs
+	if fromhere && checkcopies n Nothing
+		then go fs rs =<< dropl fs n
+		else go fs rs n
   where
-	getcopies = liftAnnex $ do
+	getcopies fs = liftAnnex $ do
 		(untrusted, have) <- trustPartition UnTrusted locs
-		numcopies <- getNumCopies =<< numCopies f
+		numcopies <- maximum <$> mapM (getNumCopies <=< numCopies) fs
 		return (length have, numcopies, S.fromList untrusted)
 
 	{- Check that we have enough copies still to drop the content.
@@ -66,20 +77,20 @@ handleDropsFrom locs rs reason fromhere key (Just f) knownpresentremote
 		| S.member u untrusted = v
 		| otherwise = decrcopies v Nothing
 
-	go [] _ = noop
+	go _ [] _ = noop
-	go (r:rest) n
+	go fs (r:rest) n
-		| uuid r `S.notMember` slocs = go rest n
+		| uuid r `S.notMember` slocs = go fs rest n
 		| checkcopies n (Just $ Remote.uuid r) =
-			dropr r n >>= go rest
+			dropr fs r n >>= go fs rest
 		| otherwise = noop
 
-	checkdrop n@(have, numcopies, _untrusted) u a =
+	checkdrop fs n@(have, numcopies, _untrusted) u a =
-		ifM (liftAnnex $ wantDrop True u (Just f))
+		ifM (liftAnnex $ allM (wantDrop True u . Just) fs)
 			( ifM (liftAnnex $ safely $ doCommand $ a (Just numcopies))
 				( do
 					debug
 						[ "dropped"
-						, f
+						, afile
 						, "(from " ++ maybe "here" show u ++ ")"
 						, "(copies now " ++ show (have - 1) ++ ")"
 						, ": " ++ reason
@@ -90,11 +101,11 @@ handleDropsFrom locs rs reason fromhere key (Just f) knownpresentremote
 			, return n
 			)
 
-	dropl n = checkdrop n Nothing $ \numcopies ->
+	dropl fs n = checkdrop fs n Nothing $ \numcopies ->
-		Command.Drop.startLocal f numcopies key knownpresentremote
+		Command.Drop.startLocal afile numcopies key knownpresentremote
 
-	dropr r n  = checkdrop n (Just $ Remote.uuid r) $ \numcopies ->
+	dropr fs r n  = checkdrop fs n (Just $ Remote.uuid r) $ \numcopies ->
-		Command.Drop.startRemote f numcopies key r
+		Command.Drop.startRemote afile numcopies key r
 
 	safely a = either (const False) id <$> tryAnnex a
 

Assistant/Install.hs

@@ -49,8 +49,9 @@ ensureInstalled = go =<< standaloneAppBase
 #ifdef darwin_HOST_OS
 		autostartfile <- userAutoStart osxAutoStartLabel
 #else
-		installMenu program
+		menufile <- desktopMenuFilePath "git-annex" <$> userDataDir
-			=<< desktopMenuFilePath "git-annex" <$> userDataDir
+		icondir <- iconDir <$> userDataDir
+		installMenu program menufile base icondir
 		autostartfile <- autoStartPath "git-annex" <$> userConfigDir
 #endif
 		installAutoStart program autostartfile

Assistant/Install/AutoStart.hs

@@ -35,4 +35,5 @@ fdoAutostart command = genDesktopEntry
 	"Autostart"
 	False
 	(command ++ " assistant --autostart")
+	Nothing
 	[]

Assistant/Install/Menu.hs

@@ -9,14 +9,20 @@
 
 module Assistant.Install.Menu where
 
+import Common
+
 import Utility.FreeDesktop
 
-installMenu :: FilePath -> FilePath -> IO ()
+installMenu :: FilePath -> FilePath -> FilePath -> FilePath -> IO ()
-installMenu command file =
+installMenu command menufile iconsrcdir icondir = do
 #ifdef darwin_HOST_OS
 	return ()
 #else
-	writeDesktopMenuFile (fdoDesktopMenu command) file
+	writeDesktopMenuFile (fdoDesktopMenu command) menufile
+	installIcon (iconsrcdir </> "logo.svg") $
+		iconFilePath (iconBaseName ++ ".svg") "scalable" icondir
+	installIcon (iconsrcdir </> "favicon.png") $
+		iconFilePath (iconBaseName ++ ".png") "16x16" icondir
 #endif
 
 {- The command can be either just "git-annex", or the full path to use
@@ -27,4 +33,15 @@ fdoDesktopMenu command = genDesktopEntry
 	"Track and sync the files in your Git Annex"
 	False
 	(command ++ " webapp")
+	(Just iconBaseName)
 	["Network", "FileTransfer"]
+
+installIcon :: FilePath -> FilePath -> IO ()
+installIcon src dest = do
+	createDirectoryIfMissing True (parentDir dest)
+	withBinaryFile src ReadMode $ \hin ->
+		withBinaryFile dest WriteMode $ \hout ->
+			hGetContents hin >>= hPutStr hout
+
+iconBaseName :: String
+iconBaseName = "git-annex"

Assistant/MakeRemote.hs

@@ -27,6 +27,8 @@ import Creds
 import qualified Data.Text as T
 import qualified Data.Map as M
 
+type RemoteName = String
+
 {- Sets up and begins syncing with a new ssh or rsync remote. -}
 makeSshRemote :: Bool -> SshData -> Maybe Cost -> Assistant Remote
 makeSshRemote forcersync sshdata mcost = do
@@ -49,10 +51,11 @@ makeSshRemote forcersync sshdata mcost = do
 		h = sshHostName sshdata
 		d
 			| T.pack "/" `T.isPrefixOf` sshDirectory sshdata = sshDirectory sshdata
+			| T.pack "~/" `T.isPrefixOf` sshDirectory sshdata = T.concat [T.pack "/", sshDirectory sshdata]
 			| otherwise = T.concat [T.pack "/~/", sshDirectory sshdata]
 	
 {- Runs an action that returns a name of the remote, and finishes adding it. -}
-addRemote :: Annex String -> Annex Remote
+addRemote :: Annex RemoteName -> Annex Remote
 addRemote a = do
 	name <- a
 	void remoteListRefresh
@@ -60,36 +63,58 @@ addRemote a = do
 		=<< Remote.byName (Just name)
 
 {- Inits a rsync special remote, and returns its name. -}
-makeRsyncRemote :: String -> String -> Annex String
+makeRsyncRemote :: RemoteName -> String -> Annex String
-makeRsyncRemote name location = makeRemote name location $
+makeRsyncRemote name location = makeRemote name location $ const $ void $
-	const $ makeSpecialRemote name Rsync.remote config
+	go =<< Command.InitRemote.findExisting name
   where
+  	go Nothing = setupSpecialRemote name Rsync.remote config
+		=<< Command.InitRemote.generateNew name
+	go (Just v) = setupSpecialRemote name Rsync.remote config v
 	config = M.fromList
 		[ ("encryption", "shared")
 		, ("rsyncurl", location)
 		, ("type", "rsync")
 		]
 
-{- Inits a new special remote, or enables an existing one.
+type SpecialRemoteMaker = RemoteName -> RemoteType -> R.RemoteConfig -> Annex RemoteName
- -
+
- - Currently, only 'weak' ciphers can be generated from the assistant,
+{- Inits a new special remote. The name is used as a suggestion, but
- - because otherwise GnuPG may block once the entropy pool is drained,
+ - will be changed if there is already a special remote with that name. -}
- - and as of now there's no way to tell the user to perform IO actions
+initSpecialRemote :: SpecialRemoteMaker
- - to refill the pool. -}
+initSpecialRemote name remotetype config = go 0
-makeSpecialRemote :: String -> RemoteType -> R.RemoteConfig -> Annex ()
-makeSpecialRemote name remotetype config =
-	go =<< Command.InitRemote.findExisting name
   where
-  	go Nothing = go =<< Just <$> Command.InitRemote.generateNew name
+	go :: Int -> Annex RemoteName
-	go (Just (u, c)) = do
+	go n = do
-		c' <- R.setup remotetype u $
+		let fullname = if n == 0  then name else name ++ show n
-			M.insert "highRandomQuality" "false" $ M.union config c
+		r <- Command.InitRemote.findExisting fullname
-		describeUUID u name
+		case r of
-		configSet u c'
+			Nothing -> setupSpecialRemote fullname remotetype config
+				=<< Command.InitRemote.generateNew fullname
+			Just _ -> go (n + 1)
+
+{- Enables an existing special remote. -}
+enableSpecialRemote :: SpecialRemoteMaker
+enableSpecialRemote name remotetype config = do
+	r <- Command.InitRemote.findExisting name
+	case r of
+		Nothing -> error $ "Cannot find a special remote named " ++ name
+		Just v -> setupSpecialRemote name remotetype config v
+
+setupSpecialRemote :: RemoteName -> RemoteType -> R.RemoteConfig -> (UUID, R.RemoteConfig) -> Annex RemoteName
+setupSpecialRemote name remotetype config (u, c) = do
+	{- Currently, only 'weak' ciphers can be generated from the
+	 - assistant, because otherwise GnuPG may block once the entropy
+	 - pool is drained, and as of now there's no way to tell the user
+	 - to perform IO actions to refill the pool. -}
+	c' <- R.setup remotetype u $
+		M.insert "highRandomQuality" "false" $ M.union config c
+	describeUUID u name
+	configSet u c'
+	return name
 
 {- Returns the name of the git remote it created. If there's already a
  - remote at the location, returns its name. -}
-makeGitRemote :: String -> String -> Annex String
+makeGitRemote :: String -> String -> Annex RemoteName
 makeGitRemote basename location = makeRemote basename location $ \name ->
 	void $ inRepo $ Git.Command.runBool
 		[Param "remote", Param "add", Param name, Param location]
@@ -98,7 +123,7 @@ makeGitRemote basename location = makeRemote basename location $ \name ->
  - action, which is passed the name of the remote to make.
  -
  - Returns the name of the remote. -}
-makeRemote :: String -> String -> (String -> Annex ()) -> Annex String
+makeRemote :: String -> String -> (RemoteName -> Annex ()) -> Annex RemoteName
 makeRemote basename location a = do
 	g <- gitRepo
 	if not (any samelocation $ Git.remotes g)
@@ -115,7 +140,7 @@ makeRemote basename location a = do
  - necessary.
  -
  - Ensures that the returned name is a legal git remote name. -}
-uniqueRemoteName :: String -> Int -> Git.Repo -> String
+uniqueRemoteName :: String -> Int -> Git.Repo -> RemoteName
 uniqueRemoteName basename n r
 	| null namecollision = name
 	| otherwise = uniqueRemoteName legalbasename (succ n) r

Assistant/NetMessager.hs

@@ -1,21 +1,22 @@
 {- git-annex assistant out of band network messager interface
  -
- - Copyright 2012 Joey Hess <joey@kitenet.net>
+ - Copyright 2012-2013 Joey Hess <joey@kitenet.net>
  -
  - Licensed under the GNU GPL version 3 or higher.
  -}
 
+{-# LANGUAGE BangPatterns #-}
+
 module Assistant.NetMessager where
 
 import Assistant.Common
 import Assistant.Types.NetMessager
 
-import Control.Concurrent
 import Control.Concurrent.STM
 import Control.Concurrent.MSampleVar
-import Control.Exception as E
 import qualified Data.Set as S
 import qualified Data.Map as M
+import qualified Data.DList as D
 
 sendNetMessage :: NetMessage -> Assistant ()
 sendNetMessage m = 
@@ -31,8 +32,9 @@ notifyNetMessagerRestart =
 waitNetMessagerRestart :: Assistant ()
 waitNetMessagerRestart = readSV <<~ (netMessagerRestart . netMessager)
 
-{- Store an important NetMessage for a client, and if the same message was
+{- Store a new important NetMessage for a client, and if an equivilant
- - already sent, remove it from sentImportantNetMessages. -}
+ - older message is already stored, remove it from both importantNetMessages
+ - and sentImportantNetMessages. -}
 storeImportantNetMessage :: NetMessage -> ClientID -> (ClientID -> Bool) -> Assistant ()
 storeImportantNetMessage m client matchingclient = go <<~ netMessager
   where
@@ -40,11 +42,12 @@ storeImportantNetMessage m client matchingclient = go <<~ netMessager
 		q <- takeTMVar $ importantNetMessages nm
 		sent <- takeTMVar $ sentImportantNetMessages nm
 		putTMVar (importantNetMessages nm) $
-			M.alter (Just . maybe (S.singleton m) (S.insert m)) client q
+			M.alter (Just . maybe (S.singleton m) (S.insert m)) client $
+				M.mapWithKey removematching q
 		putTMVar (sentImportantNetMessages nm) $
 			M.mapWithKey removematching sent
 	removematching someclient s
-		| matchingclient someclient = S.delete m s
+		| matchingclient someclient = S.filter (not . equivilantImportantNetMessages m) s
 		| otherwise = s
 
 {- Indicates that an important NetMessage has been sent to a client. -}
@@ -67,66 +70,107 @@ checkImportantNetMessages (storedclient, sentclient) = go <<~ netMessager
 		sent <- M.lookup sentclient <$> (readTMVar $ sentImportantNetMessages nm)
 		return (fromMaybe S.empty stored, fromMaybe S.empty sent)
 
-{- Runs an action that runs either the send or receive side of a push.
+{- Queues a push initiation message in the queue for the appropriate
- -
+ - side of the push but only if there is not already an initiation message
- - While the push is running, netMessagesPush will get messages put into it
+ - from the same client in the queue. -}
- - relating to this push, while any messages relating to other pushes
+queuePushInitiation :: NetMessage -> Assistant ()
- - on the same side go to netMessagesDeferred. Once the push finishes,
+queuePushInitiation msg@(Pushing clientid stage) = do
- - those deferred messages will be fed to handledeferred for processing.
+	tv <- getPushInitiationQueue side
- -}
+  	liftIO $ atomically $ do
-runPush :: PushSide -> ClientID -> (NetMessage -> Assistant ()) -> Assistant a -> Assistant a
+		r <- tryTakeTMVar tv
-runPush side clientid handledeferred a = do
+		case r of
-	nm <- getAssistant netMessager
+			Nothing -> putTMVar tv [msg]
-	let runningv = getSide side $ netMessagerPushRunning nm
+			Just l -> do
-	let setup = void $ atomically $ swapTMVar runningv $ Just clientid
+				let !l' = msg : filter differentclient l
-	let cleanup = atomically $ do
+				putTMVar tv l'
-		void $ swapTMVar runningv Nothing
-		emptytchan (getSide side $ netMessagesPush nm)
-	r <- E.bracket_ setup cleanup <~> a
-	(void . forkIO) <~> processdeferred nm
-	return r
   where
-	emptytchan c = maybe noop (const $ emptytchan c) =<< tryReadTChan c
+  	side = pushDestinationSide stage
-	processdeferred nm = do
+	differentclient (Pushing cid _) = cid /= clientid
-		s <- liftIO $ atomically $ swapTMVar (getSide side $ netMessagesPushDeferred nm) S.empty
+	differentclient _ = True
-		mapM_ rundeferred (S.toList s)
+queuePushInitiation _ = noop
-	rundeferred m = (void . (E.try :: (IO () -> IO (Either SomeException ()))))
-		<~> handledeferred m
 
-{- While a push is running, matching push messages are put into
+{- Waits for a push inititation message to be received, and runs
- - netMessagesPush, while others that involve the same side go to
+ - function to select a message from the queue. -}
- - netMessagesPushDeferred.
+waitPushInitiation :: PushSide -> ([NetMessage] -> (NetMessage, [NetMessage])) -> Assistant NetMessage
- -
+waitPushInitiation side selector = do
- - When no push is running involving the same side, returns False.
+	tv <- getPushInitiationQueue side
- -
- - To avoid bloating memory, only messages that initiate pushes are
- - deferred.
- -}
-queueNetPushMessage :: NetMessage -> Assistant Bool
-queueNetPushMessage m@(Pushing clientid stage) = do
-	nm <- getAssistant netMessager
 	liftIO $ atomically $ do
-		v <- readTMVar (getSide side $ netMessagerPushRunning nm)
+		q <- takeTMVar tv
-		case v of
+		if null q
-			Nothing -> return False
+			then retry
-			(Just runningclientid)
+			else do
-				| runningclientid == clientid -> queue nm
+				let (msg, !q') = selector q
-				| isPushInitiation stage -> defer nm
+				unless (null q') $
-				| otherwise -> discard
+					putTMVar tv q'
+				return msg
+
+{- Stores messages for a push into the appropriate inbox.
+ -
+ - To avoid overflow, only 1000 messages max are stored in any
+ - inbox, which should be far more than necessary.
+ -
+ - TODO: If we have more than 100 inboxes for different clients,
+ - discard old ones that are not currently being used by any push.
+ -}
+storeInbox :: NetMessage -> Assistant ()
+storeInbox msg@(Pushing clientid stage) = do
+	inboxes <- getInboxes side
+	stored <- liftIO $ atomically $ do
+		m <- readTVar inboxes
+		let update = \v -> do
+			writeTVar inboxes $
+				M.insertWith' const clientid v m
+			return True
+		case M.lookup clientid m of
+			Nothing -> update (1, tostore)
+			Just (sz, l)
+				| sz > 1000 -> return False
+				| otherwise ->
+					let !sz' = sz + 1
+					    !l' = D.append l tostore
+					in update (sz', l')
+	if stored
+		then netMessagerDebug clientid ["stored", logNetMessage msg, "in", show side, "inbox"]
+		else netMessagerDebug clientid ["discarded", logNetMessage msg, "; ", show side, "inbox is full"]
   where
 	side = pushDestinationSide stage
-	queue nm = do
+	tostore = D.singleton msg
-		writeTChan (getSide side $ netMessagesPush nm) m
+storeInbox _ = noop
-		return True
-	defer nm = do
-		let mv = getSide side $ netMessagesPushDeferred nm
-		s <- takeTMVar mv
-		putTMVar mv $ S.insert m s
-		return True
-	discard = return True
-queueNetPushMessage _ = return False
 
-waitNetPushMessage :: PushSide -> Assistant (NetMessage)
+{- Gets the new message for a push from its inbox.
-waitNetPushMessage side = (atomically . readTChan)
+ - Blocks until a message has been received. -}
-	<<~ (getSide side . netMessagesPush . netMessager)
+waitInbox :: ClientID -> PushSide -> Assistant (NetMessage)
+waitInbox clientid side = do
+	inboxes <- getInboxes side
+	liftIO $ atomically $ do
+		m <- readTVar inboxes
+		case M.lookup clientid m of
+			Nothing -> retry
+			Just (sz, dl)
+				| sz < 1 -> retry
+				| otherwise -> do
+					let msg = D.head dl
+					let dl' = D.tail dl
+					let !sz' = sz - 1
+					writeTVar inboxes $
+						M.insertWith' const clientid (sz', dl') m
+					return msg
 
+emptyInbox :: ClientID -> PushSide -> Assistant ()
+emptyInbox clientid side = do
+	inboxes <- getInboxes side
+	liftIO $ atomically $
+		modifyTVar' inboxes $
+			M.delete clientid
+	
+getInboxes :: PushSide -> Assistant Inboxes
+getInboxes side =
+	getSide side . netMessagerInboxes <$> getAssistant netMessager
+
+getPushInitiationQueue :: PushSide -> Assistant (TMVar [NetMessage])
+getPushInitiationQueue side =
+	getSide side . netMessagerPushInitiations <$> getAssistant netMessager
+
+netMessagerDebug :: ClientID -> [String] -> Assistant ()
+netMessagerDebug clientid l = debug $
+	"NetMessager" : l ++ [show $ logClientID clientid]

Assistant/Ssh.hs

@@ -16,6 +16,7 @@ import Git.Remote
 import Data.Text (Text)
 import qualified Data.Text as T
 import Data.Char
+import Network.URI
 
 data SshData = SshData
 	{ sshHostName :: Text
@@ -64,7 +65,10 @@ sshTranscript opts input = processTranscript "ssh" opts input
 {- Ensure that the ssh public key doesn't include any ssh options, like
  - command=foo, or other weirdness -}
 validateSshPubKey :: SshPubKey -> IO ()
-validateSshPubKey pubkey = either error return $ check $ words pubkey
+validateSshPubKey pubkey
+	| length (lines pubkey) == 1 =
+		either error return $ check $ words pubkey
+	| otherwise = error "too many lines in ssh public key"
   where
 	check [prefix, _key, comment] = do
 		checkprefix prefix
@@ -82,9 +86,10 @@ validateSshPubKey pubkey = either error return $ check $ words pubkey
 	  where
 		(ssh, keytype) = separate (== '-') prefix
 
-	checkcomment comment
+	checkcomment comment = case filter (not . safeincomment) comment of
-		| all (\c -> isAlphaNum c || c == '@' || c == '-' || c == '_' || c == '.') comment = ok
+		[] -> ok
-		| otherwise = err "bad comment in ssh public key"
+		badstuff -> err $ "bad comment in ssh public key (contains: \"" ++ badstuff ++ "\")"
+	safeincomment c = isAlphaNum c || c == '@' || c == '-' || c == '_' || c == '.'
 
 addAuthorizedKeys :: Bool -> FilePath -> SshPubKey -> IO Bool
 addAuthorizedKeys rsynconly dir pubkey = boolSystem "sh"
@@ -164,9 +169,12 @@ genSshKeyPair = withTmpDir "git-annex-keygen" $ \dir -> do
  -
  - Note that the key files are put in ~/.ssh/git-annex/, rather than directly
  - in ssh because of an **INSANE** behavior of gnome-keyring: It loads
- - ~/.ssh/*.pub, and uses them indiscriminately. But using this key
+ - ~/.ssh/ANYTHING.pub, and uses them indiscriminately. But using this key
  - for a normal login to the server will force git-annex-shell to run,
  - and locks the user out. Luckily, it does not recurse into subdirectories.
+ -
+ - Similarly, IdentitiesOnly is set in the ssh config to prevent the
+ - ssh-agent from forcing use of a different key.
  -}
 setupSshKeyPair :: SshKeyPair -> SshData -> IO SshData
 setupSshKeyPair sshkeypair sshdata = do
@@ -183,11 +191,43 @@ setupSshKeyPair sshkeypair sshdata = do
 		writeFile (sshdir </> sshpubkeyfile) (sshPubKey sshkeypair)
 
 	setSshConfig sshdata
-		[ ("IdentityFile", "~/.ssh/" ++ sshprivkeyfile) ]
+		[ ("IdentityFile", "~/.ssh/" ++ sshprivkeyfile)
+		, ("IdentitiesOnly", "yes")
+		]
   where
 	sshprivkeyfile = "git-annex" </> "key." ++ mangleSshHostName sshdata
 	sshpubkeyfile = sshprivkeyfile ++ ".pub"
 
+{- Fixes git-annex ssh key pairs configured in .ssh/config 
+ - by old versions to set IdentitiesOnly. -}
+fixSshKeyPair :: IO ()
+fixSshKeyPair = do
+	sshdir <- sshDir
+	let configfile = sshdir </> "config"
+	whenM (doesFileExist configfile) $ do
+		ls <- lines <$> readFileStrict configfile
+		let ls' = fixSshKeyPair' ls
+		when (ls /= ls') $
+			viaTmp writeFile configfile $ unlines ls'
+
+{- Strategy: Search for IdentityFile lines in for files with key.git-annex
+ - in their names. These are for git-annex ssh key pairs.
+ - Add the IdentitiesOnly line immediately after them, if not already
+ - present. -}
+fixSshKeyPair' :: [String] -> [String]
+fixSshKeyPair' = go []
+  where
+  	go c [] = reverse c
+	go c (l:[])
+		| all (`isInfixOf` l) indicators = go (fixedline l:l:c) []
+		| otherwise = go (l:c) []
+	go c (l:next:rest)
+		| all (`isInfixOf` l) indicators && not ("IdentitiesOnly" `isInfixOf` next) = 
+			go (fixedline l:l:c) (next:rest)
+		| otherwise = go (l:c) (next:rest)
+  	indicators = ["IdentityFile", "key.git-annex"]
+	fixedline tmpl = takeWhile isSpace tmpl ++ "IdentitiesOnly yes"
+
 {- Setups up a ssh config with a mangled hostname.
  - Returns a modified SshData containing the mangled hostname. -}
 setSshConfig :: SshData -> [(String, String)] -> IO SshData
@@ -212,10 +252,16 @@ setSshConfig sshdata config = do
 
 {- This hostname is specific to a given repository on the ssh host,
  - so it is based on the real hostname, the username, and the directory.
+ -
+ - The mangled hostname has the form "git-annex-realhostname-username_dir".
+ - The only use of "-" is to separate the parts shown; this is necessary
+ - to allow unMangleSshHostName to work. Any unusual characters in the
+ - username or directory are url encoded, except using "." rather than "%"
+ - (the latter has special meaning to ssh).
  -}
 mangleSshHostName :: SshData -> String
 mangleSshHostName sshdata = "git-annex-" ++ T.unpack (sshHostName sshdata)
-	++ "-" ++ filter safe extra
+	++ "-" ++ escape extra
   where
 	extra = intercalate "_" $ map T.unpack $ catMaybes
 		[ sshUserName sshdata
@@ -225,6 +271,7 @@ mangleSshHostName sshdata = "git-annex-" ++ T.unpack (sshHostName sshdata)
 		| isAlphaNum c = True
 		| c == '_' = True
 		| otherwise = False
+	escape s = replace "%" "." $ escapeURIString safe s
 
 {- Extracts the real hostname from a mangled ssh hostname. -}
 unMangleSshHostName :: String -> String

Assistant/Sync.hs

@@ -20,6 +20,7 @@ import Utility.Parallel
 import qualified Git
 import qualified Git.Branch
 import qualified Git.Command
+import qualified Git.Ref
 import qualified Remote
 import qualified Types.Remote as Remote
 import qualified Annex.Branch
@@ -112,8 +113,12 @@ pushToRemotes' now notifypushes remotes = do
 			<*> getUUID
 	let (xmppremotes, normalremotes) = partition isXMPPRemote remotes
 	ret <- go True branch g u normalremotes
-	forM_ xmppremotes $ \r ->
+	unless (null xmppremotes) $ do
-		sendNetMessage $ Pushing (getXMPPClientID r) (CanPush u)
+		shas <- liftAnnex $ map fst <$>
+			inRepo (Git.Ref.matchingWithHEAD
+				[Annex.Branch.fullname, Git.Ref.headRef])
+		forM_ xmppremotes $ \r -> sendNetMessage $
+			Pushing (getXMPPClientID r) (CanPush u shas)
 	return ret
   where
 	go _ Nothing _ _ _ = return [] -- no branch, so nothing to do

Assistant/Threads/Committer.hs

@@ -5,7 +5,7 @@
  - Licensed under the GNU GPL version 3 or higher.
  -}
 
-{-# LANGUAGE CPP, BangPatterns #-}
+{-# LANGUAGE CPP #-}
 
 module Assistant.Threads.Committer where
 
@@ -75,33 +75,38 @@ refill cs = do
 	debug ["delaying commit of", show (length cs), "changes"]
 	refillChanges cs
 
-{- Wait for one or more changes to arrive to be committed. -}
+{- Wait for one or more changes to arrive to be committed, and then
+ - runs an action to commit them. If more changes arrive while this is
+ - going on, they're handled intelligently, batching up changes into
+ - large commits where possible, doing rename detection, and
+ - commiting immediately otherwise. -}
 waitChangeTime :: (([Change], UTCTime) -> Assistant Int) -> Assistant ()
-waitChangeTime a = go [] 0
+waitChangeTime a = waitchanges 0
   where
-	go unhandled lastcommitsize = do
+	waitchanges lastcommitsize = do
 		-- Wait one one second as a simple rate limiter.
 		liftIO $ threadDelaySeconds (Seconds 1)
 		-- Now, wait until at least one change is available for
 		-- processing.
 		cs <- getChanges
-		let changes = unhandled ++ cs
+		handlechanges cs lastcommitsize
+	handlechanges changes lastcommitsize = do
 		let len = length changes
 		-- See if now's a good time to commit.
 		now <- liftIO getCurrentTime
 		case (lastcommitsize >= maxCommitSize, shouldCommit now len changes, possiblyrename changes) of
 			(True, True, _)
 				| len > maxCommitSize -> 
-					go [] =<< a (changes, now)
+					waitchanges =<< a (changes, now)
 				| otherwise -> aftermaxcommit changes
 			(_, True, False) ->
-				go [] =<< a (changes, now)
+				waitchanges =<< a (changes, now)
 			(_, True, True) -> do
 				morechanges <- getrelatedchanges changes
-				go [] =<< a (changes ++ morechanges, now)
+				waitchanges =<< a (changes ++ morechanges, now)
 			_ -> do
 				refill changes
-				go [] lastcommitsize
+				waitchanges lastcommitsize
 	
 	{- Did we perhaps only get one of the AddChange and RmChange pair
 	 - that make up a file rename? Or some of the pairs that make up 
@@ -158,14 +163,17 @@ waitChangeTime a = go [] 0
 	 -}
 	aftermaxcommit oldchanges = loop (30 :: Int)
 	  where
-	  	loop 0 = go oldchanges 0
+	  	loop 0 = continue oldchanges
 	  	loop n = do
 			liftAnnex noop -- ensure Annex state is free
 			liftIO $ threadDelaySeconds (Seconds 1)
 			changes <- getAnyChanges
 			if null changes
 				then loop (n - 1)
-				else go (oldchanges ++ changes) 0
+				else continue (oldchanges ++ changes)
+		continue cs
+			| null cs = waitchanges 0
+			| otherwise = handlechanges cs 0
 
 isRmChange :: Change -> Bool
 isRmChange (Change { changeInfo = i }) | i == RmChange = True
@@ -273,10 +281,11 @@ handleAdds :: Maybe Seconds -> [Change] -> Assistant [Change]
 handleAdds delayadd cs = returnWhen (null incomplete) $ do
 	let (pending, inprocess) = partition isPendingAddChange incomplete
 	direct <- liftAnnex isDirect
-	pending' <- if direct
+	(pending', cleanup) <- if direct
-		then return pending
+		then return (pending, noop)
 		else findnew pending
 	(postponed, toadd) <- partitionEithers <$> safeToAdd delayadd pending' inprocess
+	cleanup
 
 	unless (null postponed) $
 		refillChanges postponed
@@ -294,14 +303,13 @@ handleAdds delayadd cs = returnWhen (null incomplete) $ do
   where
 	(incomplete, otherchanges) = partition (\c -> isPendingAddChange c || isInProcessAddChange c) cs
 		
-	findnew [] = return []
+	findnew [] = return ([], noop)
 	findnew pending@(exemplar:_) = do
-		(!newfiles, cleanup) <- liftAnnex $
+		(newfiles, cleanup) <- liftAnnex $
 			inRepo (Git.LsFiles.notInRepo False $ map changeFile pending)
-		void $ liftIO cleanup
 		-- note: timestamp info is lost here
 		let ts = changeTime exemplar
-		return $ map (PendingAddChange ts) newfiles
+		return (map (PendingAddChange ts) newfiles, void $ liftIO $ cleanup)
 
 	returnWhen c a
 		| c = return otherchanges
@@ -383,7 +391,7 @@ handleAdds delayadd cs = returnWhen (null incomplete) $ do
 				return Nothing
 
 	{- Shown an alert while performing an action to add a file or
-	 - files. When only one file is added, its name is shown
+	 - files. When only a few files are added, their names are shown
 	 - in the alert. When it's a batch add, the number of files added
 	 - is shown.
 	 -
@@ -392,15 +400,10 @@ handleAdds delayadd cs = returnWhen (null incomplete) $ do
 	 - the add succeeded.
 	 -}
 	addaction [] a = a
-	addaction toadd a = alertWhile' (addFileAlert msg) $
+	addaction toadd a = alertWhile' (addFileAlert $ map changeFile toadd) $
 		(,) 
 			<$> pure True
 			<*> a
-	  where
-	  	msg = case toadd of
-			(InProcessAddChange { keySource = ks }:[]) ->
-				keyFilename ks
-			_ -> show (length toadd) ++ " files"
 
 {- Files can Either be Right to be added now,
  - or are unsafe, and must be Left for later.

Assistant/Threads/NetWatcher.hs

@@ -13,8 +13,8 @@ module Assistant.Threads.NetWatcher where
 import Assistant.Common
 import Assistant.Sync
 import Utility.ThreadScheduler
-import Remote.List
 import qualified Types.Remote as Remote
+import Assistant.DaemonStatus
 
 #if WITH_DBUS
 import Utility.DBus
@@ -125,7 +125,7 @@ listenWicdConnections client callback =
 handleConnection :: Assistant ()
 handleConnection = reconnectRemotes True =<< networkRemotes
 
-{- Finds network remotes. -}
+{- Network remotes to sync with. -}
 networkRemotes :: Assistant [Remote]
-networkRemotes = liftAnnex $
+networkRemotes = filter (isNothing . Remote.localpath) . syncRemotes
-	filter (isNothing . Remote.localpath) <$> remoteList
+	<$> getDaemonStatus

Assistant/Threads/PairListener.hs

@@ -37,6 +37,7 @@ pairListenerThread urlrenderer = namedThread "PairListener" $ do
 	go reqs cache sock = liftIO (getmsg sock []) >>= \msg -> case readish msg of
 		Nothing -> go reqs cache sock
 		Just m -> do
+			debug ["received", show msg]
 			sane <- checkSane msg
 			(pip, verified) <- verificationCheck m
 				=<< (pairingInProgress <$> getDaemonStatus)

Assistant/Threads/SanityChecker.hs

@@ -19,6 +19,7 @@ import qualified Git.Config
 import Utility.ThreadScheduler
 import qualified Assistant.Threads.Watcher as Watcher
 import Utility.LogFile
+import Utility.Batch
 import Config
 
 import Data.Time.Clock.POSIX
@@ -42,7 +43,7 @@ sanityCheckerDailyThread = namedThread "SanityCheckerDaily" $ forever $ do
 		modifyDaemonStatus_ $ \s -> s { sanityCheckRunning = True }
 
 		now <- liftIO $ getPOSIXTime -- before check started
-		r <- either showerr return =<< tryIO <~> dailyCheck
+		r <- either showerr return =<< (tryIO . batch) <~> dailyCheck
 
 		modifyDaemonStatus_ $ \s -> s
 			{ sanityCheckRunning = False

Assistant/Threads/TransferScanner.hs

@@ -24,6 +24,7 @@ import qualified Remote
 import qualified Types.Remote as Remote
 import Utility.ThreadScheduler
 import Utility.NotificationBroadcaster
+import Utility.Batch
 import qualified Git.LsFiles as LsFiles
 import qualified Backend
 import Annex.Content
@@ -114,7 +115,7 @@ failedTransferScan r = do
  - since we need to look at the locations of all keys anyway.
  -}
 expensiveScan :: UrlRenderer -> [Remote] -> Assistant ()
-expensiveScan urlrenderer rs = unless onlyweb $ do
+expensiveScan urlrenderer rs = unless onlyweb $ batch <~> do
 	debug ["starting scan of", show visiblers]
 
 	unwantedrs <- liftAnnex $ S.fromList

Assistant/Threads/Watcher.hs

@@ -226,7 +226,6 @@ onAddDirect symlinkssupported matcher file fs = do
 		| symlinkssupported = a
 		| otherwise = do
 			linktarget <- liftAnnex $ getAnnexLinkTarget file
-			liftIO $ print (file, linktarget)
 			case linktarget of
 				Nothing -> a
 				Just lt -> do

Assistant/Threads/WebApp.hs

@@ -5,7 +5,8 @@
  - Licensed under the GNU GPL version 3 or higher.
  -}
 
-{-# LANGUAGE TypeFamilies, QuasiQuotes, MultiParamTypeClasses, TemplateHaskell, OverloadedStrings, RankNTypes, CPP #-}
+{-# LANGUAGE TemplateHaskell, MultiParamTypeClasses #-}
+{-# LANGUAGE CPP #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
 module Assistant.Threads.WebApp where
@@ -50,7 +51,7 @@ webAppThread
 	-> UrlRenderer
 	-> Bool
 	-> Maybe HostName
-	-> Maybe (IO String)
+	-> Maybe (IO Url)
 	-> Maybe (Url -> FilePath -> IO ())
 	-> NamedThread
 webAppThread assistantdata urlrenderer noannex listenhost postfirstrun onstartup = thread $ liftIO $ do

Assistant/Threads/XMPPClient.hs

@@ -20,7 +20,6 @@ import qualified Remote
 import Utility.ThreadScheduler
 import Assistant.WebApp (UrlRenderer)
 import Assistant.WebApp.Types hiding (liftAssistant)
-import Assistant.WebApp.Configurators.XMPP (checkCloudRepos)
 import Assistant.Alert
 import Assistant.Pairing
 import Assistant.XMPP.Git
@@ -29,11 +28,14 @@ import Logs.UUID
 
 import Network.Protocol.XMPP
 import Control.Concurrent
+import Control.Concurrent.STM.TMVar
+import Control.Concurrent.STM (atomically)
 import qualified Data.Text as T
 import qualified Data.Set as S
 import qualified Data.Map as M
 import qualified Git.Branch
 import Data.Time.Clock
+import Control.Concurrent.Async
 
 xmppClientThread :: UrlRenderer -> NamedThread
 xmppClientThread urlrenderer = namedThread "XMPPClient" $
@@ -65,16 +67,16 @@ xmppClient urlrenderer d creds =
 		 - is not retained. -}
 		liftAssistant $
 			updateBuddyList (const noBuddies) <<~ buddyList
-		e <- client
+		void client
 		liftAssistant $ modifyDaemonStatus_ $ \s -> s
 			{ xmppClientID = Nothing }
 		now <- getCurrentTime
 		if diffUTCTime now starttime > 300
 			then do
-				liftAssistant $ debug ["connection lost; reconnecting", show e]
+				liftAssistant $ debug ["connection lost; reconnecting"]
 				retry client now
 			else do
-				liftAssistant $ debug ["connection failed; will retry", show e]
+				liftAssistant $ debug ["connection failed; will retry"]
 				threadDelaySeconds (Seconds 300)
 				retry client =<< getCurrentTime
 
@@ -87,16 +89,43 @@ xmppClient urlrenderer d creds =
 				{ xmppClientID = Just $ xmppJID creds }
 			debug ["connected", logJid selfjid]
 
-		xmppThread $ receivenotifications selfjid
+		lasttraffic <- liftIO $ atomically . newTMVar =<< getCurrentTime
-		forever $ do
-			a <- inAssistant $ relayNetMessage selfjid
-			a
 
-	receivenotifications selfjid = forever $ do
+		sender <- xmppSession $ sendnotifications selfjid
+		receiver <- xmppSession $ receivenotifications selfjid lasttraffic
+		pinger <- xmppSession $ sendpings selfjid lasttraffic
+		{- Run all 3 threads concurrently, until
+		 - any of them throw an exception.
+		 - Then kill all 3 threads, and rethrow the
+		 - exception.
+		 -
+		 - If this thread gets an exception, the 3 threads
+		 - will also be killed. -}
+		liftIO $ pinger `concurrently` sender `concurrently` receiver
+
+	sendnotifications selfjid = forever $ do
+		a <- inAssistant $ relayNetMessage selfjid
+		a
+	receivenotifications selfjid lasttraffic = forever $ do
 		l <- decodeStanza selfjid <$> getStanza
+		void $ liftIO $ atomically . swapTMVar lasttraffic =<< getCurrentTime
 		inAssistant $ debug
 			["received:", show $ map logXMPPEvent l]
 		mapM_ (handle selfjid) l
+	sendpings selfjid lasttraffic = forever $ do
+		putStanza pingstanza
+
+		startping <- liftIO $ getCurrentTime
+		liftIO $ threadDelaySeconds (Seconds 120)
+		t <- liftIO $ atomically $ readTMVar lasttraffic
+		when (t < startping) $ do
+			inAssistant $ debug ["ping timeout"]
+			error "ping timeout"
+	  where
+		{- XEP-0199 says that the server will respond with either
+		 - a ping response or an error message. Either will
+		 - cause traffic, so good enough. -}
+	  	pingstanza = xmppPing selfjid
 
 	handle selfjid (PresenceMessage p) = do
 		void $ inAssistant $ 
@@ -107,11 +136,9 @@ xmppClient urlrenderer d creds =
 	handle selfjid (GotNetMessage (PairingNotification stage c u)) =
 		maybe noop (inAssistant . pairMsgReceived urlrenderer stage u selfjid) (parseJID c)
 	handle _ (GotNetMessage m@(Pushing _ pushstage))
-		| isPushInitiation pushstage = inAssistant $
+		| isPushNotice pushstage = inAssistant $ handlePushNotice m
-			unlessM (queueNetPushMessage m) $ do
+		| isPushInitiation pushstage = inAssistant $ queuePushInitiation m
-				let checker = checkCloudRepos urlrenderer
+		| otherwise = inAssistant $ storeInbox m
-				void $ forkIO <~> handlePushInitiation checker m
-		| otherwise = void $ inAssistant $ queueNetPushMessage m
 	handle _ (Ignorable _) = noop
 	handle _ (Unknown _) = noop
 	handle _ (ProtocolError _) = noop
@@ -144,7 +171,9 @@ logXMPPEvent :: XMPPEvent -> String
 logXMPPEvent (GotNetMessage m) = logNetMessage m
 logXMPPEvent (PresenceMessage p) = logPresence p
 logXMPPEvent (Ignorable (ReceivedPresence p)) = "Ignorable " ++ logPresence p
-logXMPPEvent v = show v
+logXMPPEvent (Ignorable _) = "Ignorable message"
+logXMPPEvent (Unknown _) = "Unknown message"
+logXMPPEvent (ProtocolError _) = "Protocol error message"
 
 logPresence :: Presence -> String
 logPresence (p@Presence { presenceFrom = Just jid }) = unwords
@@ -247,13 +276,12 @@ withOtherClient selfjid c a = case parseJID c of
 withClient :: ClientID -> (JID -> XMPP ()) -> XMPP ()
 withClient c a = maybe noop a $ parseJID c
 
-{- Runs a XMPP action in a separate thread, using a session to allow it
+{- Returns an IO action that runs a XMPP action in a separate thread,
- - to access the same XMPP client. -}
+ - using a session to allow it to access the same XMPP client. -}
-xmppThread :: XMPP () -> XMPP ()
+xmppSession :: XMPP () -> XMPP (IO ())
-xmppThread a = do
+xmppSession a = do
 	s <- getSession
-	void $ liftIO $ forkIO $
+	return $ void $ runXMPP s a
-		void $ runXMPP s a
 
 {- We only pull from one remote out of the set listed in the push
  - notification, as an optimisation.

Assistant/Threads/XMPPPusher.hs

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

Assistant/TransferrerPool.hs

@@ -16,7 +16,6 @@ import Control.Concurrent.STM
 import System.Process (create_group)
 import Control.Exception (throw)
 import Control.Concurrent
-import Types.Remote (AssociatedFile)
 
 {- Runs an action with a Transferrer from the pool. -}
 withTransferrer :: FilePath -> TransferrerPool -> (Transferrer -> IO a) -> IO a

Assistant/Types/Alert.hs

@@ -39,8 +39,9 @@ type AlertCombiner = Alert -> Alert -> Maybe Alert
 data Alert = Alert
 	{ alertClass :: AlertClass
 	, alertHeader :: Maybe TenseText
-	, alertMessageRender :: [TenseChunk] -> TenseText
+	, alertMessageRender :: Alert -> TenseText
 	, alertData :: [TenseChunk]
+	, alertCounter :: Int
 	, alertBlockDisplay :: Bool
 	, alertClosable :: Bool
 	, alertPriority :: AlertPriority

Assistant/Types/NetMessager.hs

@@ -9,15 +9,17 @@ module Assistant.Types.NetMessager where
 
 import Common.Annex
 import Assistant.Pairing
+import Git.Types
 
+import qualified Data.Text as T
+import qualified Data.Set as S
+import qualified Data.Map as M
+import qualified Data.DList as D
 import Control.Concurrent.STM
 import Control.Concurrent.MSampleVar
 import Data.ByteString (ByteString)
 import qualified Data.ByteString.Char8 as B8
 import Data.Text (Text)
-import qualified Data.Text as T
-import qualified Data.Set as S
-import qualified Data.Map as M
 
 {- Messages that can be sent out of band by a network messager. -}
 data NetMessage 
@@ -37,7 +39,7 @@ type ClientID = Text
 
 data PushStage
 	-- indicates that we have data to push over the out of band network
-	= CanPush UUID
+	= CanPush UUID [Sha]
 	-- request that a git push be sent over the out of band network
 	| PushRequest UUID
 	-- indicates that a push is starting
@@ -58,10 +60,18 @@ type SequenceNum = Int
 {- NetMessages that are important (and small), and should be stored to be
  - resent when new clients are seen. -}
 isImportantNetMessage :: NetMessage -> Maybe ClientID
-isImportantNetMessage (Pushing c (CanPush _)) = Just c
+isImportantNetMessage (Pushing c (CanPush _ _)) = Just c
 isImportantNetMessage (Pushing c (PushRequest _)) = Just c
 isImportantNetMessage _ = Nothing
 
+{- Checks if two important NetMessages are equivilant.
+ - That is to say, assuming they were sent to the same client,
+ - would it do the same thing for one as for the other? -}
+equivilantImportantNetMessages :: NetMessage -> NetMessage -> Bool
+equivilantImportantNetMessages (Pushing _ (CanPush _ _)) (Pushing _ (CanPush _ _)) = True
+equivilantImportantNetMessages (Pushing _ (PushRequest _)) (Pushing _ (PushRequest _)) = True
+equivilantImportantNetMessages _ _ = False
+
 readdressNetMessage :: NetMessage -> ClientID -> NetMessage
 readdressNetMessage (PairingNotification stage _ uuid) c = PairingNotification stage c uuid
 readdressNetMessage (Pushing _ stage) c = Pushing c stage
@@ -85,16 +95,19 @@ logClientID c = T.concat [T.take 1 c, T.pack $ show $ T.length c]
 
 {- Things that initiate either side of a push, but do not actually send data. -}
 isPushInitiation :: PushStage -> Bool
-isPushInitiation (CanPush _) = True
 isPushInitiation (PushRequest _) = True
 isPushInitiation (StartingPush _) = True
 isPushInitiation _ = False
 
+isPushNotice :: PushStage -> Bool
+isPushNotice (CanPush _ _) = True
+isPushNotice _ = False
+
 data PushSide = SendPack | ReceivePack
-	deriving (Eq, Ord)
+	deriving (Eq, Ord, Show)
 
 pushDestinationSide :: PushStage -> PushSide
-pushDestinationSide (CanPush _) = ReceivePack
+pushDestinationSide (CanPush _ _) = ReceivePack
 pushDestinationSide (PushRequest _) = SendPack
 pushDestinationSide (StartingPush _) = ReceivePack
 pushDestinationSide (ReceivePackOutput _ _) = SendPack
@@ -114,6 +127,8 @@ mkSideMap gen = do
 getSide :: PushSide -> SideMap a -> a
 getSide side m = m side
 
+type Inboxes = TVar (M.Map ClientID (Int, D.DList NetMessage))
+
 data NetMessager = NetMessager
 	-- outgoing messages
 	{ netMessages :: TChan NetMessage
@@ -123,12 +138,11 @@ data NetMessager = NetMessager
 	, sentImportantNetMessages :: TMVar (M.Map ClientID (S.Set NetMessage))
 	-- write to this to restart the net messager
 	, netMessagerRestart :: MSampleVar ()
-	-- only one side of a push can be running at a time
+	-- queue of incoming messages that request the initiation of pushes
-	, netMessagerPushRunning :: SideMap (TMVar (Maybe ClientID))
+	, netMessagerPushInitiations :: SideMap (TMVar [NetMessage])
-	-- incoming messages related to a running push
+	-- incoming messages containing data for a running
-	, netMessagesPush :: SideMap (TChan NetMessage)
+	-- (or not yet started) push
-	-- incoming push messages, deferred to be processed later
+	, netMessagerInboxes :: SideMap Inboxes
-	, netMessagesPushDeferred :: SideMap (TMVar (S.Set NetMessage))
 	}
 
 newNetMessager :: IO NetMessager
@@ -137,6 +151,5 @@ newNetMessager = NetMessager
 	<*> atomically (newTMVar M.empty)
 	<*> atomically (newTMVar M.empty)
 	<*> newEmptySV
-	<*> mkSideMap (newTMVar Nothing)
+	<*> mkSideMap newEmptyTMVar
-	<*> mkSideMap newTChan
+	<*> mkSideMap (newTVar M.empty)
-	<*> mkSideMap (newTMVar S.empty)

Assistant/Types/TransferQueue.hs

@@ -9,7 +9,6 @@ module Assistant.Types.TransferQueue where
 
 import Common.Annex
 import Logs.Transfer
-import Types.Remote
 
 import Control.Concurrent.STM
 import Utility.TList

Assistant/WebApp.hs

@@ -15,19 +15,18 @@ import Assistant.Common
 import Utility.NotificationBroadcaster
 import Utility.Yesod
 
-import Yesod
 import Data.Text (Text)
 import Control.Concurrent
 import qualified Network.Wai as W
 import qualified Data.ByteString.Char8 as S8
 import qualified Data.Text as T
 
-waitNotifier :: forall sub. (Assistant NotificationBroadcaster) -> NotificationId -> GHandler sub WebApp ()
+waitNotifier :: Assistant NotificationBroadcaster -> NotificationId -> Handler ()
 waitNotifier getbroadcaster nid = liftAssistant $ do
 	b <- getbroadcaster
 	liftIO $ waitNotification $ notificationHandleFromId b nid
 
-newNotifier :: forall sub. (Assistant NotificationBroadcaster) -> GHandler sub WebApp NotificationId
+newNotifier :: Assistant NotificationBroadcaster -> Handler NotificationId
 newNotifier getbroadcaster = liftAssistant $ do
 	b <- getbroadcaster
 	liftIO $ notificationHandleToId <$> newNotificationHandle True b
@@ -36,7 +35,7 @@ newNotifier getbroadcaster = liftAssistant $ do
  - every form. -}
 webAppFormAuthToken :: Widget
 webAppFormAuthToken = do
-	webapp <- lift getYesod
+	webapp <- liftH getYesod
 	[whamlet|<input type="hidden" name="auth" value="#{secretToken webapp}">|]
 
 {- A button with an icon, and maybe label or tooltip, that can be

Assistant/WebApp/Common.hs

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

Assistant/WebApp/Configurators.hs

@@ -5,7 +5,7 @@
  - Licensed under the GNU AGPL version 3 or higher.
  -}
 
-{-# LANGUAGE TypeFamilies, QuasiQuotes, MultiParamTypeClasses, TemplateHaskell, OverloadedStrings, RankNTypes, CPP #-}
+{-# LANGUAGE QuasiQuotes, TemplateHaskell, OverloadedStrings, CPP #-}
 
 module Assistant.WebApp.Configurators where
 
@@ -16,7 +16,7 @@ import Assistant.XMPP.Client
 #endif
 
 {- The main configuration screen. -}
-getConfigurationR :: Handler RepHtml
+getConfigurationR :: Handler Html
 getConfigurationR = ifM (inFirstRun)
 	( redirect FirstRepositoryR
 	, page "Configuration" (Just Configuration) $ do
@@ -28,7 +28,7 @@ getConfigurationR = ifM (inFirstRun)
 		$(widgetFile "configurators/main")
 	)
 
-getAddRepositoryR :: Handler RepHtml
+getAddRepositoryR :: Handler Html
 getAddRepositoryR = page "Add Repository" (Just Configuration) $ do
 	let repolist = repoListDisplay mainRepoSelector
 	$(widgetFile "configurators/addrepository")

Assistant/WebApp/Configurators/AWS.hs

@@ -5,7 +5,7 @@
  - Licensed under the GNU AGPL version 3 or higher.
  -}
 
-{-# LANGUAGE CPP, FlexibleContexts, TypeFamilies, QuasiQuotes, MultiParamTypeClasses, TemplateHaskell, OverloadedStrings, RankNTypes #-}
+{-# LANGUAGE CPP, QuasiQuotes, TemplateHaskell, OverloadedStrings #-}
 
 module Assistant.WebApp.Configurators.AWS where
 
@@ -29,10 +29,10 @@ import qualified Data.Text as T
 import qualified Data.Map as M
 import Data.Char
 
-awsConfigurator :: Widget -> Handler RepHtml
+awsConfigurator :: Widget -> Handler Html
 awsConfigurator = page "Add an Amazon repository" (Just Configuration)
 
-glacierConfigurator :: Widget -> Handler RepHtml
+glacierConfigurator :: Widget -> Handler Html
 glacierConfigurator a = do
 	ifM (liftIO $ inPath "glacier")
 		( awsConfigurator a
@@ -63,7 +63,7 @@ data AWSCreds = AWSCreds Text Text
 extractCreds :: AWSInput -> AWSCreds
 extractCreds i = AWSCreds (accessKeyID i) (secretAccessKey i)
 
-s3InputAForm :: Maybe CredPair -> AForm WebApp WebApp AWSInput
+s3InputAForm :: Maybe CredPair -> MkAForm AWSInput
 s3InputAForm defcreds = AWSInput
 	<$> accessKeyIDFieldWithHelp (T.pack . fst <$> defcreds)
 	<*> secretAccessKeyField (T.pack . snd <$> defcreds)
@@ -78,7 +78,7 @@ s3InputAForm defcreds = AWSInput
 		, ("Reduced redundancy (costs less)", ReducedRedundancy)
 		]
 
-glacierInputAForm :: Maybe CredPair -> AForm WebApp WebApp AWSInput
+glacierInputAForm :: Maybe CredPair -> MkAForm AWSInput
 glacierInputAForm defcreds = AWSInput
 	<$> accessKeyIDFieldWithHelp (T.pack . fst <$> defcreds)
 	<*> secretAccessKeyField (T.pack . snd <$> defcreds)
@@ -87,15 +87,15 @@ glacierInputAForm defcreds = AWSInput
 	<*> areq textField "Repository name" (Just "glacier")
 	<*> enableEncryptionField
 
-awsCredsAForm :: Maybe CredPair -> AForm WebApp WebApp AWSCreds
+awsCredsAForm :: Maybe CredPair -> MkAForm AWSCreds
 awsCredsAForm defcreds = AWSCreds
 	<$> accessKeyIDFieldWithHelp (T.pack . fst <$> defcreds)
 	<*> secretAccessKeyField (T.pack . snd <$> defcreds)
 
-accessKeyIDField :: Widget -> Maybe Text -> AForm WebApp WebApp Text
+accessKeyIDField :: Widget -> Maybe Text -> MkAForm Text
 accessKeyIDField help def = areq (textField `withNote` help) "Access Key ID" def
 
-accessKeyIDFieldWithHelp :: Maybe Text -> AForm WebApp WebApp Text
+accessKeyIDFieldWithHelp :: Maybe Text -> MkAForm Text
 accessKeyIDFieldWithHelp def = accessKeyIDField help def
   where
 	help = [whamlet|
@@ -103,28 +103,28 @@ accessKeyIDFieldWithHelp def = accessKeyIDField help def
   Get Amazon access keys
 |]
 
-secretAccessKeyField :: Maybe Text -> AForm WebApp WebApp Text
+secretAccessKeyField :: Maybe Text -> MkAForm Text
 secretAccessKeyField def = areq passwordField "Secret Access Key" def
 
-datacenterField :: AWS.Service -> AForm WebApp WebApp Text
+datacenterField :: AWS.Service -> MkAForm Text
 datacenterField service = areq (selectFieldList list) "Datacenter" defregion
   where
 	list = M.toList $ AWS.regionMap service
 	defregion = Just $ AWS.defaultRegion service
 
-getAddS3R :: Handler RepHtml
+getAddS3R :: Handler Html
 getAddS3R = postAddS3R
 
-postAddS3R :: Handler RepHtml
+postAddS3R :: Handler Html
 #ifdef WITH_S3
 postAddS3R = awsConfigurator $ do
 	defcreds <- liftAnnex previouslyUsedAWSCreds
-	((result, form), enctype) <- lift $
+	((result, form), enctype) <- liftH $
 		runFormPost $ renderBootstrap $ s3InputAForm defcreds
 	case result of
-		FormSuccess input -> lift $ do
+		FormSuccess input -> liftH $ do
 			let name = T.unpack $ repoName input
-			makeAWSRemote S3.remote (extractCreds input) name setgroup $ M.fromList
+			makeAWSRemote initSpecialRemote S3.remote (extractCreds input) name setgroup $ M.fromList
 				[ configureEncryption $ enableEncryption input
 				, ("type", "S3")
 				, ("datacenter", T.unpack $ datacenter input)
@@ -138,19 +138,19 @@ postAddS3R = awsConfigurator $ do
 postAddS3R = error "S3 not supported by this build"
 #endif
 
-getAddGlacierR :: Handler RepHtml
+getAddGlacierR :: Handler Html
 getAddGlacierR = postAddGlacierR
 
-postAddGlacierR :: Handler RepHtml
+postAddGlacierR :: Handler Html
 #ifdef WITH_S3
 postAddGlacierR = glacierConfigurator $ do
 	defcreds <- liftAnnex previouslyUsedAWSCreds
-	((result, form), enctype) <- lift $
+	((result, form), enctype) <- liftH $
 		runFormPost $ renderBootstrap $ glacierInputAForm defcreds
 	case result of
-		FormSuccess input -> lift $ do
+		FormSuccess input -> liftH $ do
 			let name = T.unpack $ repoName input
-			makeAWSRemote Glacier.remote (extractCreds input) name setgroup $ M.fromList
+			makeAWSRemote initSpecialRemote Glacier.remote (extractCreds input) name setgroup $ M.fromList
 				[ configureEncryption $ enableEncryption input
 				, ("type", "glacier")
 				, ("datacenter", T.unpack $ datacenter input)
@@ -163,7 +163,7 @@ postAddGlacierR = glacierConfigurator $ do
 postAddGlacierR = error "S3 not supported by this build"
 #endif
 
-getEnableS3R :: UUID -> Handler RepHtml
+getEnableS3R :: UUID -> Handler Html
 #ifdef WITH_S3
 getEnableS3R uuid = do
 	m <- liftAnnex readRemoteLog
@@ -174,31 +174,31 @@ getEnableS3R uuid = do
 getEnableS3R = postEnableS3R
 #endif
 
-postEnableS3R :: UUID -> Handler RepHtml
+postEnableS3R :: UUID -> Handler Html
 #ifdef WITH_S3
 postEnableS3R uuid = awsConfigurator $ enableAWSRemote S3.remote uuid
 #else
 postEnableS3R _ = error "S3 not supported by this build"
 #endif
 
-getEnableGlacierR :: UUID -> Handler RepHtml
+getEnableGlacierR :: UUID -> Handler Html
 getEnableGlacierR = postEnableGlacierR
 
-postEnableGlacierR :: UUID -> Handler RepHtml
+postEnableGlacierR :: UUID -> Handler Html
 postEnableGlacierR = glacierConfigurator . enableAWSRemote Glacier.remote
 
 enableAWSRemote :: RemoteType -> UUID -> Widget
 #ifdef WITH_S3
 enableAWSRemote remotetype uuid = do
 	defcreds <- liftAnnex previouslyUsedAWSCreds
-	((result, form), enctype) <- lift $
+	((result, form), enctype) <- liftH $
 		runFormPost $ renderBootstrap $ awsCredsAForm defcreds
 	case result of
-		FormSuccess creds -> lift $ do
+		FormSuccess creds -> liftH $ do
 			m <- liftAnnex readRemoteLog
 			let name = fromJust $ M.lookup "name" $
 				fromJust $ M.lookup uuid m
-			makeAWSRemote remotetype creds name (const noop) M.empty
+			makeAWSRemote enableSpecialRemote remotetype creds name (const noop) M.empty
 		_ -> do
 			description <- liftAnnex $
 				T.pack <$> Remote.prettyUUID uuid
@@ -207,13 +207,11 @@ enableAWSRemote remotetype uuid = do
 enableAWSRemote _ _ = error "S3 not supported by this build"
 #endif
 
-makeAWSRemote :: RemoteType -> AWSCreds -> String -> (Remote -> Handler ()) -> RemoteConfig -> Handler ()
+makeAWSRemote :: SpecialRemoteMaker -> RemoteType -> AWSCreds -> String -> (Remote -> Handler ()) -> RemoteConfig -> Handler ()
-makeAWSRemote remotetype (AWSCreds ak sk) name setup config = do
+makeAWSRemote maker remotetype (AWSCreds ak sk) name setup config = do
-	remotename <- liftAnnex $ fromRepo $ uniqueRemoteName name 0
 	liftIO $ AWS.setCredsEnv (T.unpack ak, T.unpack sk)
 	r <- liftAnnex $ addRemote $ do
-		makeSpecialRemote hostname remotetype config
+		maker hostname remotetype config
-		return remotename
 	setup r
 	liftAssistant $ syncRemote r
 	redirect $ EditNewCloudRepositoryR $ Remote.uuid r

Assistant/WebApp/Configurators/Delete.hs

@@ -5,7 +5,7 @@
  - Licensed under the GNU AGPL version 3 or higher.
  -}
 
-{-# LANGUAGE TypeFamilies, QuasiQuotes, MultiParamTypeClasses, TemplateHaskell, OverloadedStrings, RankNTypes #-}
+{-# LANGUAGE QuasiQuotes, TemplateHaskell, OverloadedStrings #-}
 
 module Assistant.WebApp.Configurators.Delete where
 
@@ -28,24 +28,24 @@ import qualified Data.Text as T
 import qualified Data.Map as M
 import System.Path
 
-notCurrentRepo :: UUID -> Handler RepHtml -> Handler RepHtml
+notCurrentRepo :: UUID -> Handler Html -> Handler Html
 notCurrentRepo uuid a = go =<< liftAnnex (Remote.remoteFromUUID uuid)
   where
   	go Nothing = redirect DeleteCurrentRepositoryR
 	go (Just _) = a
 
-getDisableRepositoryR :: UUID -> Handler RepHtml
+getDisableRepositoryR :: UUID -> Handler Html
 getDisableRepositoryR uuid = notCurrentRepo uuid $ do
 	void $ liftAssistant $ disableRemote uuid
 	redirect DashboardR
 
-getDeleteRepositoryR :: UUID -> Handler RepHtml
+getDeleteRepositoryR :: UUID -> Handler Html
 getDeleteRepositoryR uuid = notCurrentRepo uuid $
 	deletionPage $ do
 		reponame <- liftAnnex $ Remote.prettyUUID uuid
 		$(widgetFile "configurators/delete/start")
 
-getStartDeleteRepositoryR :: UUID -> Handler RepHtml
+getStartDeleteRepositoryR :: UUID -> Handler Html
 getStartDeleteRepositoryR uuid = do
 	remote <- fromMaybe (error "unknown remote")
 		<$> liftAnnex (Remote.remoteFromUUID uuid)
@@ -55,7 +55,7 @@ getStartDeleteRepositoryR uuid = do
 	liftAssistant $ addScanRemotes True [remote]
 	redirect DashboardR
 
-getFinishDeleteRepositoryR :: UUID -> Handler RepHtml
+getFinishDeleteRepositoryR :: UUID -> Handler Html
 getFinishDeleteRepositoryR uuid = deletionPage $ do
 	void $ liftAssistant $ removeRemote uuid
 
@@ -64,22 +64,22 @@ getFinishDeleteRepositoryR uuid = deletionPage $ do
 	gitrepo <- liftAnnex $ M.notMember uuid <$> readRemoteLog
 	$(widgetFile "configurators/delete/finished")	
 
-getDeleteCurrentRepositoryR :: Handler RepHtml
+getDeleteCurrentRepositoryR :: Handler Html
 getDeleteCurrentRepositoryR = deleteCurrentRepository
 
-postDeleteCurrentRepositoryR :: Handler RepHtml
+postDeleteCurrentRepositoryR :: Handler Html
 postDeleteCurrentRepositoryR = deleteCurrentRepository
 
-deleteCurrentRepository :: Handler RepHtml
+deleteCurrentRepository :: Handler Html
 deleteCurrentRepository = dangerPage $ do
-	reldir <- fromJust . relDir <$> lift getYesod
+	reldir <- fromJust . relDir <$> liftH getYesod
 	havegitremotes <- haveremotes syncGitRemotes
 	havedataremotes <- haveremotes syncDataRemotes
-	((result, form), enctype) <- lift $
+	((result, form), enctype) <- liftH $
 		runFormPost $ renderBootstrap $ sanityVerifierAForm $
 			SanityVerifier magicphrase
 	case result of
-		FormSuccess _ -> lift $ do
+		FormSuccess _ -> liftH $ do
 			dir <- liftAnnex $ fromRepo Git.repoPath
 			liftIO $ removeAutoStartFile dir
 
@@ -107,7 +107,7 @@ deleteCurrentRepository = dangerPage $ do
 data SanityVerifier = SanityVerifier T.Text
 	deriving (Eq)
 
-sanityVerifierAForm :: SanityVerifier -> AForm WebApp WebApp SanityVerifier
+sanityVerifierAForm :: SanityVerifier -> MkAForm SanityVerifier
 sanityVerifierAForm template = SanityVerifier
 	<$> areq checksanity "Confirm deletion?" Nothing
   where
@@ -116,10 +116,10 @@ sanityVerifierAForm template = SanityVerifier
 	
 	insane = "Maybe this is not a good idea..." :: Text
 
-deletionPage :: Widget -> Handler RepHtml
+deletionPage :: Widget -> Handler Html
 deletionPage = page "Delete repository" (Just Configuration)
 
-dangerPage :: Widget -> Handler RepHtml
+dangerPage :: Widget -> Handler Html
 dangerPage = page "Danger danger danger" (Just Configuration)
 
 magicphrase :: Text

Assistant/WebApp/Configurators/Edit.hs

@@ -5,7 +5,7 @@
  - Licensed under the GNU AGPL version 3 or higher.
  -}
 
-{-# LANGUAGE CPP, TypeFamilies, QuasiQuotes, MultiParamTypeClasses, TemplateHaskell, OverloadedStrings, RankNTypes #-}
+{-# LANGUAGE CPP, QuasiQuotes, TemplateHaskell, OverloadedStrings #-}
 
 module Assistant.WebApp.Configurators.Edit where
 
@@ -132,9 +132,10 @@ setRepoConfig uuid mremote oldc newc = do
 
 	legalName = makeLegalName . T.unpack . repoName
 
-editRepositoryAForm :: RepoConfig -> AForm WebApp WebApp RepoConfig
+editRepositoryAForm :: Bool -> RepoConfig -> MkAForm RepoConfig
-editRepositoryAForm def = RepoConfig
+editRepositoryAForm ishere def = RepoConfig
-	<$> areq textField "Name" (Just $ repoName def)
+	<$> areq (if ishere then readonlyTextField else textField)
+		"Name" (Just $ repoName def)
 	<*> aopt textField "Description" (Just $ repoDescription def)
 	<*> areq (selectFieldList groups `withNote` help) "Repository group" (Just $ repoGroup def)
 	<*> associateddirectory
@@ -154,33 +155,33 @@ editRepositoryAForm def = RepoConfig
 		Nothing -> aopt hiddenField "" Nothing
 		Just d -> aopt textField "Associated directory" (Just $ Just d)
 
-getEditRepositoryR :: UUID -> Handler RepHtml
+getEditRepositoryR :: UUID -> Handler Html
 getEditRepositoryR = postEditRepositoryR
 
-postEditRepositoryR :: UUID -> Handler RepHtml
+postEditRepositoryR :: UUID -> Handler Html
 postEditRepositoryR = editForm False
 
-getEditNewRepositoryR :: UUID -> Handler RepHtml
+getEditNewRepositoryR :: UUID -> Handler Html
 getEditNewRepositoryR = postEditNewRepositoryR
 
-postEditNewRepositoryR :: UUID -> Handler RepHtml
+postEditNewRepositoryR :: UUID -> Handler Html
 postEditNewRepositoryR = editForm True
 
-getEditNewCloudRepositoryR :: UUID -> Handler RepHtml
+getEditNewCloudRepositoryR :: UUID -> Handler Html
 getEditNewCloudRepositoryR = postEditNewCloudRepositoryR
 
-postEditNewCloudRepositoryR :: UUID -> Handler RepHtml
+postEditNewCloudRepositoryR :: UUID -> Handler Html
 postEditNewCloudRepositoryR uuid = xmppNeeded >> editForm True uuid
 
-editForm :: Bool -> UUID -> Handler RepHtml
+editForm :: Bool -> UUID -> Handler Html
-editForm new uuid = page "Configure repository" (Just Configuration) $ do
+editForm new uuid = page "Edit repository" (Just Configuration) $ do
 	mremote <- liftAnnex $ Remote.remoteFromUUID uuid
 	curr <- liftAnnex $ getRepoConfig uuid mremote
 	liftAnnex $ checkAssociatedDirectory curr mremote
-	((result, form), enctype) <- lift $
+	((result, form), enctype) <- liftH $
-		runFormPost $ renderBootstrap $ editRepositoryAForm curr
+		runFormPost $ renderBootstrap $ editRepositoryAForm (isNothing mremote) curr
 	case result of
-		FormSuccess input -> lift $ do
+		FormSuccess input -> liftH $ do
 			setRepoConfig uuid mremote curr input
 			liftAnnex $ checkAssociatedDirectory input mremote
 			redirect DashboardR

Assistant/WebApp/Configurators/IA.hs

@@ -5,7 +5,7 @@
  - Licensed under the GNU AGPL version 3 or higher.
  -}
 
-{-# LANGUAGE CPP, FlexibleContexts, TypeFamilies, QuasiQuotes, MultiParamTypeClasses, TemplateHaskell, OverloadedStrings, RankNTypes #-}
+{-# LANGUAGE CPP, QuasiQuotes, TemplateHaskell, OverloadedStrings #-}
 
 module Assistant.WebApp.Configurators.IA where
 
@@ -30,7 +30,7 @@ import qualified Data.Map as M
 import Data.Char
 import Network.URI
 
-iaConfigurator :: Widget -> Handler RepHtml
+iaConfigurator :: Widget -> Handler Html
 iaConfigurator = page "Add an Internet Archive repository" (Just Configuration)
 
 data IAInput = IAInput
@@ -79,7 +79,7 @@ showMediaType MediaVideo = "videos & movies"
 showMediaType MediaAudio = "audio & music"
 showMediaType MediaOmitted = "other"
 
-iaInputAForm :: Maybe CredPair -> AForm WebApp WebApp IAInput
+iaInputAForm :: Maybe CredPair -> MkAForm IAInput
 iaInputAForm defcreds = IAInput
 	<$> accessKeyIDFieldWithHelp (T.pack . fst <$> defcreds)
 	<*> AWS.secretAccessKeyField (T.pack . snd <$> defcreds)
@@ -99,7 +99,7 @@ itemNameHelp = [whamlet|
   will be uploaded to your Internet Archive item.
 |]
 
-iaCredsAForm :: Maybe CredPair -> AForm WebApp WebApp AWS.AWSCreds
+iaCredsAForm :: Maybe CredPair -> MkAForm AWS.AWSCreds
 iaCredsAForm defcreds = AWS.AWSCreds
         <$> accessKeyIDFieldWithHelp (T.pack . fst <$> defcreds)
         <*> AWS.secretAccessKeyField (T.pack . snd <$> defcreds)
@@ -110,7 +110,7 @@ previouslyUsedIACreds = previouslyUsedCredPair AWS.creds S3.remote $
 	AWS.isIARemoteConfig . Remote.config
 #endif
 
-accessKeyIDFieldWithHelp :: Maybe Text -> AForm WebApp WebApp Text
+accessKeyIDFieldWithHelp :: Maybe Text -> MkAForm Text
 accessKeyIDFieldWithHelp def = AWS.accessKeyIDField help def
   where
 	help = [whamlet|
@@ -118,19 +118,19 @@ accessKeyIDFieldWithHelp def = AWS.accessKeyIDField help def
   Get Internet Archive access keys
 |]
 
-getAddIAR :: Handler RepHtml
+getAddIAR :: Handler Html
 getAddIAR = postAddIAR
 
-postAddIAR :: Handler RepHtml
+postAddIAR :: Handler Html
 #ifdef WITH_S3
 postAddIAR = iaConfigurator $ do
 	defcreds <- liftAnnex previouslyUsedIACreds
-	((result, form), enctype) <- lift $
+	((result, form), enctype) <- liftH $
 		runFormPost $ renderBootstrap $ iaInputAForm defcreds
 	case result of
-		FormSuccess input -> lift $ do
+		FormSuccess input -> liftH $ do
 			let name = escapeBucket $ T.unpack $ itemName input
-			AWS.makeAWSRemote S3.remote (extractCreds input) name setgroup $
+			AWS.makeAWSRemote initSpecialRemote S3.remote (extractCreds input) name setgroup $
 				M.fromList $ catMaybes
 					[ Just $ configureEncryption NoEncryption
 					, Just ("type", "S3")
@@ -153,10 +153,10 @@ postAddIAR = iaConfigurator $ do
 postAddIAR = error "S3 not supported by this build"
 #endif
 
-getEnableIAR :: UUID -> Handler RepHtml
+getEnableIAR :: UUID -> Handler Html
 getEnableIAR = postEnableIAR
 
-postEnableIAR :: UUID -> Handler RepHtml
+postEnableIAR :: UUID -> Handler Html
 #ifdef WITH_S3
 postEnableIAR = iaConfigurator . enableIARemote
 #else
@@ -167,14 +167,14 @@ postEnableIAR _ = error "S3 not supported by this build"
 enableIARemote :: UUID -> Widget
 enableIARemote uuid = do
 	defcreds <- liftAnnex previouslyUsedIACreds
-	((result, form), enctype) <- lift $
+	((result, form), enctype) <- liftH $
 		runFormPost $ renderBootstrap $ iaCredsAForm defcreds
 	case result of
-		FormSuccess creds -> lift $ do
+		FormSuccess creds -> liftH $ do
 			m <- liftAnnex readRemoteLog
 			let name = fromJust $ M.lookup "name" $
 				fromJust $ M.lookup uuid m
-			AWS.makeAWSRemote S3.remote creds name (const noop) M.empty
+			AWS.makeAWSRemote enableSpecialRemote S3.remote creds name (const noop) M.empty
 		_ -> do
 			description <- liftAnnex $
 				T.pack <$> Remote.prettyUUID uuid

Assistant/WebApp/Configurators/Local.hs

@@ -5,7 +5,7 @@
  - Licensed under the GNU AGPL version 3 or higher.
  -}
 
-{-# LANGUAGE CPP, TypeFamilies, QuasiQuotes, MultiParamTypeClasses, TemplateHaskell, OverloadedStrings, RankNTypes #-}
+{-# LANGUAGE CPP, QuasiQuotes, TemplateHaskell, OverloadedStrings, RankNTypes, KindSignatures, TypeFamilies #-}
 
 module Assistant.WebApp.Configurators.Local where
 
@@ -38,6 +38,7 @@ import Config
 import qualified Data.Text as T
 import qualified Data.Map as M
 import Data.Char
+import qualified Text.Hamlet as Hamlet
 
 data RepositoryPath = RepositoryPath Text
 	deriving Show
@@ -46,7 +47,11 @@ data RepositoryPath = RepositoryPath Text
  -
  - Validates that the path entered is not empty, and is a safe value
  - to use as a repository. -}
+#if MIN_VERSION_yesod(1,2,0)
+repositoryPathField :: forall (m :: * -> *). (MonadIO m, HandlerSite m ~ WebApp) => Bool -> Field m Text
+#else
 repositoryPathField :: forall sub. Bool -> Field sub WebApp Text
+#endif
 repositoryPathField autofocus = Field
 #if ! MIN_VERSION_yesod_form(1,2,0)
 	{ fieldParse = parse
@@ -119,7 +124,7 @@ defaultRepositoryPath firstrun = do
 			)
 	legit d = not <$> doesFileExist (d </> "git-annex")
 
-newRepositoryForm :: FilePath -> Form RepositoryPath
+newRepositoryForm :: FilePath -> Hamlet.Html -> MkMForm RepositoryPath
 newRepositoryForm defpath msg = do
 	(pathRes, pathView) <- mreq (repositoryPathField True) ""
 		(Just $ T.pack $ addTrailingPathSeparator defpath)
@@ -133,40 +138,47 @@ newRepositoryForm defpath msg = do
 	return (RepositoryPath <$> pathRes, form)
 
 {- Making the first repository, when starting the webapp for the first time. -}
-getFirstRepositoryR :: Handler RepHtml
+getFirstRepositoryR :: Handler Html
 getFirstRepositoryR = postFirstRepositoryR
-postFirstRepositoryR :: Handler RepHtml
+postFirstRepositoryR :: Handler Html
 postFirstRepositoryR = page "Getting started" (Just Configuration) $ do
 #ifdef __ANDROID__
 	androidspecial <- liftIO $ doesDirectoryExist "/sdcard/DCIM"
 	let path = "/sdcard/annex"
 #else
 	let androidspecial = False
-	path <- liftIO . defaultRepositoryPath =<< lift inFirstRun
+	path <- liftIO . defaultRepositoryPath =<< liftH inFirstRun
 #endif
-	((res, form), enctype) <- lift $ runFormPost $ newRepositoryForm path
+	((res, form), enctype) <- liftH $ runFormPost $ newRepositoryForm path
 	case res of
-		FormSuccess (RepositoryPath p) -> lift $
+		FormSuccess (RepositoryPath p) -> liftH $
-			startFullAssistant (T.unpack p) ClientGroup
+			startFullAssistant (T.unpack p) ClientGroup Nothing
 		_ -> $(widgetFile "configurators/newrepository/first")
 
 getAndroidCameraRepositoryR :: Handler ()
-getAndroidCameraRepositoryR = startFullAssistant "/sdcard/DCIM" SourceGroup
+getAndroidCameraRepositoryR = 
+	startFullAssistant "/sdcard/DCIM" SourceGroup $ Just addignore	
+  where
+  	addignore = do
+		liftIO $ unlessM (doesFileExist ".gitignore") $
+			writeFile ".gitignore" ".thumbnails/*"
+		void $ inRepo $
+			Git.Command.runBool [Param "add", File ".gitignore"]
 
 {- Adding a new local repository, which may be entirely separate, or may
  - be connected to the current repository. -}
-getNewRepositoryR :: Handler RepHtml
+getNewRepositoryR :: Handler Html
 getNewRepositoryR = postNewRepositoryR
-postNewRepositoryR :: Handler RepHtml
+postNewRepositoryR :: Handler Html
 postNewRepositoryR = page "Add another repository" (Just Configuration) $ do
 	home <- liftIO myHomeDir
-	((res, form), enctype) <- lift $ runFormPost $ newRepositoryForm home
+	((res, form), enctype) <- liftH $ runFormPost $ newRepositoryForm home
 	case res of
 		FormSuccess (RepositoryPath p) -> do
 			let path = T.unpack p
 			isnew <- liftIO $ makeRepo path False
 			u <- liftIO $ initRepo isnew True path Nothing
-			lift $ liftAnnexOr () $ setStandardGroup u ClientGroup
+			liftH $ liftAnnexOr () $ setStandardGroup u ClientGroup
 			liftIO $ addAutoStartFile path
 			liftIO $ startAssistant path
 			askcombine u path
@@ -174,10 +186,10 @@ postNewRepositoryR = page "Add another repository" (Just Configuration) $ do
   where
 	askcombine newrepouuid newrepopath = do
 		newrepo <- liftIO $ relHome newrepopath
-		mainrepo <- fromJust . relDir <$> lift getYesod
+		mainrepo <- fromJust . relDir <$> liftH getYesod
 		$(widgetFile "configurators/newrepository/combine")
 
-getCombineRepositoryR :: FilePathAndUUID -> Handler RepHtml
+getCombineRepositoryR :: FilePathAndUUID -> Handler Html
 getCombineRepositoryR (FilePathAndUUID newrepopath newrepouuid) = do
 	r <- combineRepos newrepopath remotename
 	liftAssistant $ syncRemote r
@@ -185,7 +197,7 @@ getCombineRepositoryR (FilePathAndUUID newrepopath newrepouuid) = do
   where
 	remotename = takeFileName newrepopath
 
-selectDriveForm :: [RemovableDrive] -> Form RemovableDrive
+selectDriveForm :: [RemovableDrive] -> Hamlet.Html -> MkMForm RemovableDrive
 selectDriveForm drives = renderBootstrap $ RemovableDrive
 	<$> pure Nothing
 	<*> areq (selectFieldList pairs) "Select drive:" Nothing
@@ -208,24 +220,24 @@ removableDriveRepository drive =
 	T.unpack (mountPoint drive) </> T.unpack (driveRepoPath drive)
 
 {- Adding a removable drive. -}
-getAddDriveR :: Handler RepHtml
+getAddDriveR :: Handler Html
 getAddDriveR = postAddDriveR
-postAddDriveR :: Handler RepHtml
+postAddDriveR :: Handler Html
 postAddDriveR = page "Add a removable drive" (Just Configuration) $ do
 	removabledrives <- liftIO $ driveList
 	writabledrives <- liftIO $
 		filterM (canWrite . T.unpack . mountPoint) removabledrives
-	((res, form), enctype) <- lift $ runFormPost $
+	((res, form), enctype) <- liftH $ runFormPost $
 		selectDriveForm (sort writabledrives)
 	case res of
-		FormSuccess drive -> lift $ redirect $ ConfirmAddDriveR drive
+		FormSuccess drive -> liftH $ redirect $ ConfirmAddDriveR drive
 		_ -> $(widgetFile "configurators/adddrive")
 
 {- The repo may already exist, when adding removable media
  - that has already been used elsewhere. If so, check
  - the UUID of the repo and see if it's one we know. If not,
  - the user must confirm the repository merge. -}
-getConfirmAddDriveR :: RemovableDrive -> Handler RepHtml
+getConfirmAddDriveR :: RemovableDrive -> Handler Html
 getConfirmAddDriveR drive = do
 	ifM (needconfirm)
 		( page "Combine repositories?" (Just Configuration) $
@@ -249,13 +261,17 @@ getConfirmAddDriveR drive = do
 cloneModal :: Widget
 cloneModal = $(widgetFile "configurators/adddrive/clonemodal")
 
-getFinishAddDriveR :: RemovableDrive -> Handler RepHtml
+getFinishAddDriveR :: RemovableDrive -> Handler Html
 getFinishAddDriveR drive = make >>= redirect . EditNewRepositoryR
   where
   	make = do
 		liftIO $ createDirectoryIfMissing True dir
 		isnew <- liftIO $ makeRepo dir True
 		u <- liftIO $ initRepo isnew False dir $ Just remotename
+		{- Removable drives are not reliable media, so enable fsync. -}
+		liftIO $ inDir dir $
+			setConfig (ConfigKey "core.fsyncobjectfiles")
+				(Git.Config.boolConfig True)
 		r <- combineRepos dir remotename
 		liftAnnex $ setStandardGroup u TransferGroup
 		liftAssistant $ syncRemote r
@@ -273,7 +289,7 @@ combineRepos dir name = liftAnnex $ do
 	liftIO $ inDir dir $ void $ makeGitRemote hostname hostlocation
 	addRemote $ makeGitRemote name dir
 
-getEnableDirectoryR :: UUID -> Handler RepHtml
+getEnableDirectoryR :: UUID -> Handler Html
 getEnableDirectoryR uuid = page "Enable a repository" (Just Configuration) $ do
 	description <- liftAnnex $ T.pack <$> prettyUUID uuid
 	$(widgetFile "configurators/enabledirectory")
@@ -311,13 +327,15 @@ driveList = return []
 {- Bootstraps from first run mode to a fully running assistant in a
  - repository, by running the postFirstRun callback, which returns the
  - url to the new webapp. -}
-startFullAssistant :: FilePath -> StandardGroup -> Handler ()
+startFullAssistant :: FilePath -> StandardGroup -> Maybe (Annex ())-> Handler ()
-startFullAssistant path repogroup = do
+startFullAssistant path repogroup setup = do
 	webapp <- getYesod
 	url <- liftIO $ do
 		isnew <- makeRepo path False
 		u <- initRepo isnew True path Nothing
-		inDir path $ setStandardGroup u repogroup
+		inDir path $ do
+			setStandardGroup u repogroup
+			maybe noop id setup
 		addAutoStartFile path
 		setCurrentDirectory path
 		fromJust $ postFirstRun webapp
@@ -352,9 +370,7 @@ inDir dir a = do
 {- Creates a new repository, and returns its UUID. -}
 initRepo :: Bool -> Bool -> FilePath -> Maybe String -> IO UUID
 initRepo True primary_assistant_repo dir desc = inDir dir $ do
-	{- Initialize a git-annex repository in a directory with a description. -}
+	initRepo' desc
-	unlessM isInitialized $
-		initialize desc
 	{- Initialize the master branch, so things that expect
 	 - to have it will work, before any files are added. -}
 	unlessM (Git.Config.isBare <$> gitRepo) $
@@ -377,9 +393,13 @@ initRepo True primary_assistant_repo dir desc = inDir dir $ do
 	getUUID
 {- Repo already exists, could be a non-git-annex repo though. -}
 initRepo False _ dir desc = inDir dir $ do
+	initRepo' desc
+	getUUID
+
+initRepo' :: Maybe String -> Annex ()
+initRepo' desc = do
 	unlessM isInitialized $
 		initialize desc
-	getUUID
 
 {- Checks if the user can write to a directory.
  -

Assistant/WebApp/Configurators/Pairing.hs

@@ -5,7 +5,7 @@
  - Licensed under the GNU AGPL version 3 or higher.
  -}
 
-{-# LANGUAGE TypeFamilies, QuasiQuotes, MultiParamTypeClasses, TemplateHaskell, OverloadedStrings, RankNTypes #-}
+{-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, OverloadedStrings #-}
 {-# LANGUAGE CPP #-}
 
 module Assistant.WebApp.Configurators.Pairing where
@@ -49,7 +49,7 @@ import Control.Concurrent
 import qualified Data.Set as S
 #endif
 
-getStartXMPPPairFriendR :: Handler RepHtml
+getStartXMPPPairFriendR :: Handler Html
 #ifdef WITH_XMPP
 getStartXMPPPairFriendR = ifM (isJust <$> liftAnnex getXMPPCreds)
 	( do
@@ -65,11 +65,11 @@ getStartXMPPPairFriendR = ifM (isJust <$> liftAnnex getXMPPCreds)
 #else
 getStartXMPPPairFriendR = noXMPPPairing
 
-noXMPPPairing :: Handler RepHtml
+noXMPPPairing :: Handler Html
 noXMPPPairing = noPairing "XMPP"
 #endif
 
-getStartXMPPPairSelfR :: Handler RepHtml
+getStartXMPPPairSelfR :: Handler Html
 #ifdef WITH_XMPP
 getStartXMPPPairSelfR = go =<< liftAnnex getXMPPCreds
   where
@@ -87,14 +87,14 @@ getStartXMPPPairSelfR = go =<< liftAnnex getXMPPCreds
 getStartXMPPPairSelfR = noXMPPPairing
 #endif
 
-getRunningXMPPPairFriendR :: BuddyKey -> Handler RepHtml
+getRunningXMPPPairFriendR :: BuddyKey -> Handler Html
 getRunningXMPPPairFriendR = sendXMPPPairRequest . Just
 
-getRunningXMPPPairSelfR :: Handler RepHtml
+getRunningXMPPPairSelfR :: Handler Html
 getRunningXMPPPairSelfR = sendXMPPPairRequest Nothing
 
 {- Sends a XMPP pair request, to a buddy or to self. -}
-sendXMPPPairRequest :: Maybe BuddyKey -> Handler RepHtml
+sendXMPPPairRequest :: Maybe BuddyKey -> Handler Html
 #ifdef WITH_XMPP
 sendXMPPPairRequest mbid = do
 	bid <- maybe getself return mbid
@@ -125,28 +125,28 @@ sendXMPPPairRequest _ = noXMPPPairing
 #endif
 
 {- Starts local pairing. -}
-getStartLocalPairR :: Handler RepHtml
+getStartLocalPairR :: Handler Html
 getStartLocalPairR = postStartLocalPairR
-postStartLocalPairR :: Handler RepHtml
+postStartLocalPairR :: Handler Html
 #ifdef WITH_PAIRING
 postStartLocalPairR = promptSecret Nothing $
 	startLocalPairing PairReq noop pairingAlert Nothing
 #else
 postStartLocalPairR = noLocalPairing
 
-noLocalPairing :: Handler RepHtml
+noLocalPairing :: Handler Html
 noLocalPairing = noPairing "local"
 #endif
 
 {- Runs on the system that responds to a local pair request; sets up the ssh
  - authorized key first so that the originating host can immediately sync
  - with us. -}
-getFinishLocalPairR :: PairMsg -> Handler RepHtml
+getFinishLocalPairR :: PairMsg -> Handler Html
 getFinishLocalPairR = postFinishLocalPairR
-postFinishLocalPairR :: PairMsg -> Handler RepHtml
+postFinishLocalPairR :: PairMsg -> Handler Html
 #ifdef WITH_PAIRING
 postFinishLocalPairR msg = promptSecret (Just msg) $ \_ secret -> do
-	repodir <- lift $ repoPath <$> liftAnnex gitRepo
+	repodir <- liftH $ repoPath <$> liftAnnex gitRepo
 	liftIO $ setup repodir
 	startLocalPairing PairAck (cleanup repodir) alert uuid "" secret
   where
@@ -159,7 +159,7 @@ postFinishLocalPairR msg = promptSecret (Just msg) $ \_ secret -> do
 postFinishLocalPairR _ = noLocalPairing
 #endif
 
-getConfirmXMPPPairFriendR :: PairKey -> Handler RepHtml
+getConfirmXMPPPairFriendR :: PairKey -> Handler Html
 #ifdef WITH_XMPP
 getConfirmXMPPPairFriendR pairkey@(PairKey _ t) = case parseJID t of
 	Nothing -> error "bad JID"
@@ -170,7 +170,7 @@ getConfirmXMPPPairFriendR pairkey@(PairKey _ t) = case parseJID t of
 getConfirmXMPPPairFriendR _ = noXMPPPairing
 #endif
 
-getFinishXMPPPairFriendR :: PairKey -> Handler RepHtml
+getFinishXMPPPairFriendR :: PairKey -> Handler Html
 #ifdef WITH_XMPP
 getFinishXMPPPairFriendR (PairKey theiruuid t) = case parseJID t of
 	Nothing -> error "bad JID"
@@ -188,13 +188,13 @@ getFinishXMPPPairFriendR _ = noXMPPPairing
 {- Displays a page indicating pairing status and 
  - prompting to set up cloud repositories. -}
 #ifdef WITH_XMPP
-xmppPairStatus :: Bool -> Maybe JID -> Handler RepHtml
+xmppPairStatus :: Bool -> Maybe JID -> Handler Html
 xmppPairStatus inprogress theirjid = pairPage $ do
 	let friend = buddyName <$> theirjid
 	$(widgetFile "configurators/pairing/xmpp/end")
 #endif
 
-getRunningLocalPairR :: SecretReminder -> Handler RepHtml
+getRunningLocalPairR :: SecretReminder -> Handler Html
 #ifdef WITH_PAIRING
 getRunningLocalPairR s = pairPage $ do
 	let secret = fromSecretReminder s
@@ -216,8 +216,8 @@ getRunningLocalPairR _ = noLocalPairing
  -}
 startLocalPairing :: PairStage -> IO () -> (AlertButton -> Alert) -> Maybe UUID -> Text -> Secret -> Widget
 startLocalPairing stage oncancel alert muuid displaysecret secret = do
-	urlrender <- lift getUrlRender
+	urlrender <- liftH getUrlRender
-	reldir <- fromJust . relDir <$> lift getYesod
+	reldir <- fromJust . relDir <$> liftH getYesod
 
 	sendrequests <- liftAssistant $ asIO2 $ mksendrequests urlrender
 	{- Generating a ssh key pair can take a while, so do it in the
@@ -235,7 +235,7 @@ startLocalPairing stage oncancel alert muuid displaysecret secret = do
 		startSending pip stage $ sendrequests sender
 	void $ liftIO $ forkIO thread
 
-	lift $ redirect $ RunningLocalPairR $ toSecretReminder displaysecret
+	liftH $ redirect $ RunningLocalPairR $ toSecretReminder displaysecret
   where
 	{- Sends pairing messages until the thread is killed,
 	 - and shows an activity alert while doing it.
@@ -262,9 +262,9 @@ data InputSecret = InputSecret { secretText :: Maybe Text }
 
 {- If a PairMsg is passed in, ensures that the user enters a secret
  - that can validate it. -}
-promptSecret :: Maybe PairMsg -> (Text -> Secret -> Widget) -> Handler RepHtml
+promptSecret :: Maybe PairMsg -> (Text -> Secret -> Widget) -> Handler Html
 promptSecret msg cont = pairPage $ do
-	((result, form), enctype) <- lift $
+	((result, form), enctype) <- liftH $
 		runFormPost $ renderBootstrap $
 			InputSecret <$> aopt textField "Secret phrase" Nothing
 	case result of
@@ -319,9 +319,9 @@ sampleQuote = T.unwords
 
 #endif
 
-pairPage :: Widget -> Handler RepHtml
+pairPage :: Widget -> Handler Html
 pairPage = page "Pairing" (Just Configuration)
 
-noPairing :: Text -> Handler RepHtml
+noPairing :: Text -> Handler Html
 noPairing pairingtype = pairPage $
 	$(widgetFile "configurators/pairing/disabled")

Assistant/WebApp/Configurators/Preferences.hs

@@ -18,9 +18,9 @@ import qualified Git
 import Config
 import Config.Files
 import Utility.DataUnits
+import Git.Config
 
 import qualified Data.Text as T
-import System.Log.Logger
 
 data PrefsForm = PrefsForm
 	{ diskReserve :: Text
@@ -29,7 +29,7 @@ data PrefsForm = PrefsForm
 	, debugEnabled :: Bool
 	}
 
-prefsAForm :: PrefsForm -> AForm WebApp WebApp PrefsForm
+prefsAForm :: PrefsForm -> MkAForm PrefsForm
 prefsAForm def = PrefsForm
 	<$> areq (storageField `withNote` diskreservenote)
 		"Disk reserve" (Just $ diskReserve def)
@@ -68,7 +68,7 @@ getPrefs = PrefsForm
 	<$> (T.pack . roughSize storageUnits False . annexDiskReserve <$> Annex.getGitConfig)
 	<*> (annexNumCopies <$> Annex.getGitConfig)
 	<*> inAutoStartFile
-	<*> ((==) <$> (pure $ Just DEBUG) <*> (liftIO $ getLevel <$> getRootLogger))
+	<*> (annexDebug <$> Annex.getGitConfig)
 
 storePrefs :: PrefsForm -> Annex ()
 storePrefs p = do
@@ -79,18 +79,20 @@ storePrefs p = do
 		liftIO $ if autoStart p
 			then addAutoStartFile here
 			else removeAutoStartFile here
-	liftIO $ updateGlobalLogger rootLoggerName $ setLevel $
+	setConfig (annexConfig "debug") (boolConfig $ debugEnabled p)
-		if debugEnabled p then DEBUG else WARNING
+	liftIO $ if debugEnabled p
+		then enableDebugOutput 
+		else disableDebugOutput
 
-getPreferencesR :: Handler RepHtml
+getPreferencesR :: Handler Html
 getPreferencesR = postPreferencesR
-postPreferencesR :: Handler RepHtml
+postPreferencesR :: Handler Html
 postPreferencesR = page "Preferences" (Just Configuration) $ do
-	((result, form), enctype) <- lift $ do
+	((result, form), enctype) <- liftH $ do
 		current <- liftAnnex getPrefs
 		runFormPost $ renderBootstrap $ prefsAForm current
 	case result of
-		FormSuccess new -> lift $ do
+		FormSuccess new -> liftH $ do
 			liftAnnex $ storePrefs new
 			redirect ConfigurationR
 		_ -> $(widgetFile "configurators/preferences")

Assistant/WebApp/Configurators/Ssh.hs

@@ -5,7 +5,7 @@
  - Licensed under the GNU AGPL version 3 or higher.
  -}
 
-{-# LANGUAGE TypeFamilies, QuasiQuotes, MultiParamTypeClasses, TemplateHaskell, OverloadedStrings, RankNTypes #-}
+{-# LANGUAGE QuasiQuotes, TemplateHaskell, OverloadedStrings #-}
 {-# LANGUAGE CPP #-}
 
 module Assistant.WebApp.Configurators.Ssh where
@@ -24,7 +24,7 @@ import qualified Data.Text as T
 import qualified Data.Map as M
 import Network.Socket
 
-sshConfigurator :: Widget -> Handler RepHtml
+sshConfigurator :: Widget -> Handler Html
 sshConfigurator = page "Add a remote server" (Just Configuration)
 
 data SshInput = SshInput
@@ -58,7 +58,11 @@ mkSshInput s = SshInput
 	, inputPort = sshPort s
 	}
 
-sshInputAForm :: (Field WebApp WebApp Text) -> SshInput -> AForm WebApp WebApp SshInput
+#if MIN_VERSION_yesod(1,2,0)
+sshInputAForm :: Field Handler Text -> SshInput -> AForm Handler SshInput
+#else
+sshInputAForm :: Field WebApp WebApp Text -> SshInput -> AForm WebApp WebApp SshInput
+#endif
 sshInputAForm hostnamefield def = SshInput
 	<$> aopt check_hostname "Host name" (Just $ inputHostname def)
 	<*> aopt check_username "User name" (Just $ inputUsername def)
@@ -102,12 +106,12 @@ usable (UnusableServer _) = False
 usable UsableRsyncServer = True
 usable UsableSshInput = True
 
-getAddSshR :: Handler RepHtml
+getAddSshR :: Handler Html
 getAddSshR = postAddSshR
-postAddSshR :: Handler RepHtml
+postAddSshR :: Handler Html
 postAddSshR = sshConfigurator $ do
 	u <- liftIO $ T.pack <$> myUserName
-	((result, form), enctype) <- lift $
+	((result, form), enctype) <- liftH $
 		runFormPost $ renderBootstrap $ sshInputAForm textField $
 			SshInput Nothing (Just u) Nothing 22
 	case result of
@@ -115,7 +119,7 @@ postAddSshR = sshConfigurator $ do
 			s <- liftIO $ testServer sshinput
 			case s of
 				Left status -> showform form enctype status
-				Right sshdata -> lift $ redirect $ ConfirmSshR sshdata
+				Right sshdata -> liftH $ redirect $ ConfirmSshR sshdata
 		_ -> showform form enctype UntestedServer
   where
 	showform form enctype status = $(widgetFile "configurators/ssh/add")
@@ -131,19 +135,19 @@ sshTestModal = $(widgetFile "configurators/ssh/testmodal")
  - Note that there's no EnableSshR because ssh remotes are not special
  - remotes, and so their configuration is not shared between repositories.
  -}
-getEnableRsyncR :: UUID -> Handler RepHtml
+getEnableRsyncR :: UUID -> Handler Html
 getEnableRsyncR = postEnableRsyncR
-postEnableRsyncR :: UUID -> Handler RepHtml
+postEnableRsyncR :: UUID -> Handler Html
 postEnableRsyncR u = do
 	m <- fromMaybe M.empty . M.lookup u <$> liftAnnex readRemoteLog
 	case (parseSshRsyncUrl =<< M.lookup "rsyncurl" m, M.lookup "name" m) of
 		(Just sshinput, Just reponame) -> sshConfigurator $ do
-			((result, form), enctype) <- lift $
+			((result, form), enctype) <- liftH $
 				runFormPost $ renderBootstrap $ sshInputAForm textField sshinput
 			case result of
 				FormSuccess sshinput'
 					| isRsyncNet (inputHostname sshinput') ->
-						void $ lift $ makeRsyncNet sshinput' reponame (const noop)
+						void $ liftH $ makeRsyncNet sshinput' reponame (const noop)
 					| otherwise -> do
 						s <- liftIO $ testServer sshinput'
 						case s of
@@ -156,7 +160,7 @@ postEnableRsyncR u = do
 	showform form enctype status = do
 		description <- liftAnnex $ T.pack <$> prettyUUID u
 		$(widgetFile "configurators/ssh/enable")
-	enable sshdata = lift $ redirect $ ConfirmSshR $
+	enable sshdata = liftH $ redirect $ ConfirmSshR $
 		sshdata { rsyncOnly = True }
 
 {- Converts a rsyncurl value to a SshInput. But only if it's a ssh rsync
@@ -249,18 +253,18 @@ testServer sshinput@(SshInput { inputHostname = Just hn }) = do
 
 {- Runs a ssh command; if it fails shows the user the transcript,
  - and if it succeeds, runs an action. -}
-sshSetup :: [String] -> String -> Handler RepHtml -> Handler RepHtml
+sshSetup :: [String] -> String -> Handler Html -> Handler Html
 sshSetup opts input a = do
 	(transcript, ok) <- liftIO $ sshTranscript opts (Just input)
 	if ok
 		then a
 		else showSshErr transcript
 
-showSshErr :: String -> Handler RepHtml
+showSshErr :: String -> Handler Html
 showSshErr msg = sshConfigurator $
 	$(widgetFile "configurators/ssh/error")
 
-getConfirmSshR :: SshData -> Handler RepHtml
+getConfirmSshR :: SshData -> Handler Html
 getConfirmSshR sshdata = sshConfigurator $
 	$(widgetFile "configurators/ssh/confirm")
 
@@ -269,29 +273,29 @@ getRetrySshR sshdata = do
 	s <- liftIO $ testServer $ mkSshInput sshdata
 	redirect $ either (const $ ConfirmSshR sshdata) ConfirmSshR s
 
-getMakeSshGitR :: SshData -> Handler RepHtml
+getMakeSshGitR :: SshData -> Handler Html
 getMakeSshGitR = makeSsh False setupGroup
 
-getMakeSshRsyncR :: SshData -> Handler RepHtml
+getMakeSshRsyncR :: SshData -> Handler Html
 getMakeSshRsyncR = makeSsh True setupGroup
 
-makeSsh :: Bool -> (Remote -> Handler ()) -> SshData -> Handler RepHtml
+makeSsh :: Bool -> (Remote -> Handler ()) -> SshData -> Handler Html
 makeSsh rsync setup sshdata
 	| needsPubKey sshdata = do
 		keypair <- liftIO genSshKeyPair
 		sshdata' <- liftIO $ setupSshKeyPair keypair sshdata
-		makeSsh' rsync setup sshdata' (Just keypair)
+		makeSsh' rsync setup sshdata sshdata' (Just keypair)
 	| sshPort sshdata /= 22 = do
 		sshdata' <- liftIO $ setSshConfig sshdata []
-		makeSsh' rsync setup sshdata' Nothing
+		makeSsh' rsync setup sshdata sshdata' Nothing
-	| otherwise = makeSsh' rsync setup sshdata Nothing
+	| otherwise = makeSsh' rsync setup sshdata sshdata Nothing
 
-makeSsh' :: Bool -> (Remote -> Handler ()) -> SshData -> Maybe SshKeyPair -> Handler RepHtml
+makeSsh' :: Bool -> (Remote -> Handler ()) -> SshData -> SshData -> Maybe SshKeyPair -> Handler Html
-makeSsh' rsync setup sshdata keypair =
+makeSsh' rsync setup origsshdata sshdata keypair = do
-	sshSetup [sshhost, remoteCommand] "" $
+	sshSetup ["-p", show (sshPort origsshdata), sshhost, remoteCommand] "" $
 		makeSshRepo rsync setup sshdata
   where
-	sshhost = genSshHost (sshHostName sshdata) (sshUserName sshdata)
+	sshhost = genSshHost (sshHostName origsshdata) (sshUserName origsshdata)
 	remotedir = T.unpack $ sshDirectory sshdata
 	remoteCommand = shellWrap $ intercalate "&&" $ catMaybes
 		[ Just $ "mkdir -p " ++ shellEscape remotedir
@@ -299,19 +303,19 @@ makeSsh' rsync setup sshdata keypair =
 		, if rsync then Nothing else Just "if [ ! -d .git ]; then git init --bare --shared; fi"
 		, if rsync then Nothing else Just "git annex init"
 		, if needsPubKey sshdata
-			then addAuthorizedKeysCommand (rsyncOnly sshdata) remotedir . sshPubKey <$> keypair
+			then addAuthorizedKeysCommand (rsync || rsyncOnly sshdata) remotedir . sshPubKey <$> keypair
 			else Nothing
 		]
 
-makeSshRepo :: Bool -> (Remote -> Handler ()) -> SshData -> Handler RepHtml
+makeSshRepo :: Bool -> (Remote -> Handler ()) -> SshData -> Handler Html
 makeSshRepo forcersync setup sshdata = do
 	r <- liftAssistant $ makeSshRemote forcersync sshdata Nothing
 	setup r
 	redirect $ EditNewCloudRepositoryR $ Remote.uuid r
 
-getAddRsyncNetR :: Handler RepHtml
+getAddRsyncNetR :: Handler Html
 getAddRsyncNetR = postAddRsyncNetR
-postAddRsyncNetR :: Handler RepHtml
+postAddRsyncNetR :: Handler Html
 postAddRsyncNetR = do
 	((result, form), enctype) <- runFormPost $
 		renderBootstrap $ sshInputAForm hostnamefield $
@@ -339,7 +343,7 @@ postAddRsyncNetR = do
   user name something like "7491"
 |]
 
-makeRsyncNet :: SshInput -> String -> (Remote -> Handler ()) -> Handler RepHtml
+makeRsyncNet :: SshInput -> String -> (Remote -> Handler ()) -> Handler Html
 makeRsyncNet sshinput reponame setup = do
 	knownhost <- liftIO $ maybe (return False) knownHost (inputHostname sshinput)
 	keypair <- liftIO $ genSshKeyPair

Assistant/WebApp/Configurators/WebDAV.hs

@@ -5,7 +5,7 @@
  - Licensed under the GNU AGPL version 3 or higher.
  -}
 
-{-# LANGUAGE CPP, TypeFamilies, QuasiQuotes, MultiParamTypeClasses, TemplateHaskell, OverloadedStrings, RankNTypes #-}
+{-# LANGUAGE CPP, QuasiQuotes, TemplateHaskell, OverloadedStrings #-}
 
 module Assistant.WebApp.Configurators.WebDAV where
 
@@ -26,10 +26,10 @@ import qualified Data.Map as M
 import qualified Data.Text as T
 import Network.URI
 
-webDAVConfigurator :: Widget -> Handler RepHtml
+webDAVConfigurator :: Widget -> Handler Html
 webDAVConfigurator = page "Add a WebDAV repository" (Just Configuration)
 
-boxConfigurator :: Widget -> Handler RepHtml
+boxConfigurator :: Widget -> Handler Html
 boxConfigurator = page "Add a Box.com repository" (Just Configuration)
 
 data WebDAVInput = WebDAVInput
@@ -43,7 +43,7 @@ data WebDAVInput = WebDAVInput
 toCredPair :: WebDAVInput -> CredPair
 toCredPair input = (T.unpack $ user input, T.unpack $ password input)
 
-boxComAForm :: Maybe CredPair -> AForm WebApp WebApp WebDAVInput
+boxComAForm :: Maybe CredPair -> MkAForm WebDAVInput
 boxComAForm defcreds = WebDAVInput
 	<$> areq textField "Username or Email" (T.pack . fst <$> defcreds)
 	<*> areq passwordField "Box.com Password" (T.pack . snd <$> defcreds)
@@ -51,7 +51,7 @@ boxComAForm defcreds = WebDAVInput
 	<*> areq textField "Directory" (Just "annex")
 	<*> enableEncryptionField
 
-webDAVCredsAForm :: Maybe CredPair -> AForm WebApp WebApp WebDAVInput
+webDAVCredsAForm :: Maybe CredPair -> MkAForm WebDAVInput
 webDAVCredsAForm defcreds = WebDAVInput
 	<$> areq textField "Username or Email" (T.pack . fst <$> defcreds)
 	<*> areq passwordField "Password" (T.pack . snd <$> defcreds)
@@ -59,17 +59,17 @@ webDAVCredsAForm defcreds = WebDAVInput
 	<*> pure T.empty
 	<*> pure NoEncryption -- not used!
 
-getAddBoxComR :: Handler RepHtml
+getAddBoxComR :: Handler Html
 getAddBoxComR = postAddBoxComR
-postAddBoxComR :: Handler RepHtml
+postAddBoxComR :: Handler Html
 #ifdef WITH_WEBDAV
 postAddBoxComR = boxConfigurator $ do
 	defcreds <- liftAnnex $ previouslyUsedWebDAVCreds "box.com"
-	((result, form), enctype) <- lift $
+	((result, form), enctype) <- liftH $
 		runFormPost $ renderBootstrap $ boxComAForm defcreds
 	case result of
-		FormSuccess input -> lift $ 
+		FormSuccess input -> liftH $ 
-			makeWebDavRemote "box.com" (toCredPair input) setgroup $ M.fromList
+			makeWebDavRemote initSpecialRemote "box.com" (toCredPair input) setgroup $ M.fromList
 				[ configureEncryption $ enableEncryption input
 				, ("embedcreds", if embedCreds input then "yes" else "no")
 				, ("type", "webdav")
@@ -87,9 +87,9 @@ postAddBoxComR = boxConfigurator $ do
 postAddBoxComR = error "WebDAV not supported by this build"
 #endif
 
-getEnableWebDAVR :: UUID -> Handler RepHtml
+getEnableWebDAVR :: UUID -> Handler Html
 getEnableWebDAVR = postEnableWebDAVR
-postEnableWebDAVR :: UUID -> Handler RepHtml
+postEnableWebDAVR :: UUID -> Handler Html
 #ifdef WITH_WEBDAV
 postEnableWebDAVR uuid = do
 	m <- liftAnnex readRemoteLog
@@ -99,8 +99,8 @@ postEnableWebDAVR uuid = do
 	mcreds <- liftAnnex $
 		getRemoteCredPairFor "webdav" c (WebDAV.davCreds uuid)
 	case mcreds of
-		Just creds -> webDAVConfigurator $ lift $
+		Just creds -> webDAVConfigurator $ liftH $
-			makeWebDavRemote name creds (const noop) M.empty
+			makeWebDavRemote enableSpecialRemote name creds (const noop) M.empty
 		Nothing
 			| "box.com/" `isInfixOf` url ->
 				boxConfigurator $ showform name url
@@ -111,11 +111,11 @@ postEnableWebDAVR uuid = do
 		defcreds <- liftAnnex $ 
 			maybe (pure Nothing) previouslyUsedWebDAVCreds $
 				urlHost url
-		((result, form), enctype) <- lift $
+		((result, form), enctype) <- liftH $
 			runFormPost $ renderBootstrap $ webDAVCredsAForm defcreds
 		case result of
-			FormSuccess input -> lift $
+			FormSuccess input -> liftH $
-				makeWebDavRemote name (toCredPair input) (const noop) M.empty
+				makeWebDavRemote enableSpecialRemote name (toCredPair input) (const noop) M.empty
 			_ -> do
 				description <- liftAnnex $
 					T.pack <$> Remote.prettyUUID uuid
@@ -125,13 +125,10 @@ postEnableWebDAVR _ = error "WebDAV not supported by this build"
 #endif
 
 #ifdef WITH_WEBDAV
-makeWebDavRemote :: String -> CredPair -> (Remote -> Handler ()) -> RemoteConfig -> Handler ()
+makeWebDavRemote :: SpecialRemoteMaker -> String -> CredPair -> (Remote -> Handler ()) -> RemoteConfig -> Handler ()
-makeWebDavRemote name creds setup config = do
+makeWebDavRemote maker name creds setup config = do
-	remotename <- liftAnnex $ fromRepo $ uniqueRemoteName name 0
 	liftIO $ WebDAV.setCredsEnv creds
-	r <- liftAnnex $ addRemote $ do
+	r <- liftAnnex $ addRemote $ maker name WebDAV.remote config
-		makeSpecialRemote name WebDAV.remote config
-		return remotename
 	setup r
 	liftAssistant $ syncRemote r
 	redirect $ EditNewCloudRepositoryR $ Remote.uuid r

Assistant/WebApp/Configurators/XMPP.hs

@@ -5,7 +5,7 @@
  - Licensed under the GNU AGPL version 3 or higher.
  -}
 
-{-# LANGUAGE TypeFamilies, QuasiQuotes, MultiParamTypeClasses, TemplateHaskell, OverloadedStrings #-}
+{-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, OverloadedStrings, FlexibleContexts #-}
 {-# LANGUAGE CPP #-}
 
 module Assistant.WebApp.Configurators.XMPP where
@@ -13,25 +13,23 @@ module Assistant.WebApp.Configurators.XMPP where
 import Assistant.WebApp.Common
 import Assistant.WebApp.Notifications
 import Utility.NotificationBroadcaster
-import qualified Remote
 #ifdef WITH_XMPP
+import qualified Remote
 import Assistant.XMPP.Client
 import Assistant.XMPP.Buddies
 import Assistant.Types.Buddies
 import Assistant.NetMessager
 import Assistant.Alert
 import Assistant.DaemonStatus
-import Utility.SRV
 import Assistant.WebApp.RepoList
 import Assistant.WebApp.Configurators
 import Assistant.XMPP
 #endif
 
 #ifdef WITH_XMPP
-import Network
 import Network.Protocol.XMPP
+import Network
 import qualified Data.Text as T
-import Control.Exception (SomeException)
 #endif
 
 {- Displays an alert suggesting to configure XMPP. -}
@@ -81,7 +79,7 @@ getBuddyName u = go =<< getclientjid
 		<$> getDaemonStatus
 #endif
 
-getNeedCloudRepoR :: UUID -> Handler RepHtml
+getNeedCloudRepoR :: UUID -> Handler Html
 #ifdef WITH_XMPP
 getNeedCloudRepoR for = page "Cloud repository needed" (Just Configuration) $ do
 	buddyname <- liftAssistant $ getBuddyName for
@@ -91,34 +89,34 @@ getNeedCloudRepoR _ = xmppPage $
 	$(widgetFile "configurators/xmpp/disabled")
 #endif
 
-getXMPPConfigR :: Handler RepHtml
+getXMPPConfigR :: Handler Html
 getXMPPConfigR = postXMPPConfigR
 
-postXMPPConfigR :: Handler RepHtml
+postXMPPConfigR :: Handler Html
 postXMPPConfigR = xmppform DashboardR
 
-getXMPPConfigForPairFriendR :: Handler RepHtml
+getXMPPConfigForPairFriendR :: Handler Html
 getXMPPConfigForPairFriendR = postXMPPConfigForPairFriendR
 
-postXMPPConfigForPairFriendR :: Handler RepHtml
+postXMPPConfigForPairFriendR :: Handler Html
 postXMPPConfigForPairFriendR = xmppform StartXMPPPairFriendR
 
-getXMPPConfigForPairSelfR :: Handler RepHtml
+getXMPPConfigForPairSelfR :: Handler Html
 getXMPPConfigForPairSelfR = postXMPPConfigForPairSelfR
 
-postXMPPConfigForPairSelfR :: Handler RepHtml
+postXMPPConfigForPairSelfR :: Handler Html
 postXMPPConfigForPairSelfR = xmppform StartXMPPPairSelfR
 
-xmppform :: Route WebApp -> Handler RepHtml
+xmppform :: Route WebApp -> Handler Html
 #ifdef WITH_XMPP
 xmppform next = xmppPage $ do
-	((result, form), enctype) <- lift $ do
+	((result, form), enctype) <- liftH $ do
 		oldcreds <- liftAnnex getXMPPCreds
 		runFormPost $ renderBootstrap $ xmppAForm $
 			creds2Form <$> oldcreds
 	let showform problem = $(widgetFile "configurators/xmpp")
 	case result of
-		FormSuccess f -> either (showform . Just . show) (lift . storecreds)
+		FormSuccess f -> either (showform . Just) (liftH . storecreds)
 			=<< liftIO (validateForm f)
 		_ -> showform Nothing
   where
@@ -135,12 +133,12 @@ xmppform _ = xmppPage $
  -
  - Returns a div, which will be inserted into the calling page.
  -}
-getBuddyListR :: NotificationId -> Handler RepHtml
+getBuddyListR :: NotificationId -> Handler Html
 getBuddyListR nid = do
 	waitNotifier getBuddyListBroadcaster nid
 
 	p <- widgetToPageContent buddyListDisplay
-	hamletToRepHtml $ [hamlet|^{pageBody p}|]
+	giveUrlRenderer $ [hamlet|^{pageBody p}|]
 
 buddyListDisplay :: Widget
 buddyListDisplay = do
@@ -173,44 +171,50 @@ data XMPPForm = XMPPForm
 creds2Form :: XMPPCreds -> XMPPForm
 creds2Form c = XMPPForm (xmppJID c) (xmppPassword c)
 
-xmppAForm :: (Maybe XMPPForm) -> AForm WebApp WebApp XMPPForm
+xmppAForm :: (Maybe XMPPForm) -> MkAForm XMPPForm
 xmppAForm def = XMPPForm
 	<$> areq jidField "Jabber address" (formJID <$> def)
 	<*> areq passwordField "Password" Nothing
 
-jidField :: Field WebApp WebApp Text
+jidField :: MkField Text
 jidField = checkBool (isJust . parseJID) bad textField
   where
 	bad :: Text
 	bad = "This should look like an email address.."
 
-validateForm :: XMPPForm -> IO (Either SomeException XMPPCreds)
+validateForm :: XMPPForm -> IO (Either String XMPPCreds)
 validateForm f = do
 	let jid = fromMaybe (error "bad JID") $ parseJID (formJID f)
-	let domain = T.unpack $ strDomain $ jidDomain jid
-	hostports <- lookupSRV $ mkSRVTcp "xmpp-client" domain
 	let username = fromMaybe "" (strNode <$> jidNode jid)
-	case hostports of
+	testXMPP $ XMPPCreds
-		((h, PortNumber p):_) -> testXMPP $ XMPPCreds
+		{ xmppUsername = username
-			{ xmppUsername = username
+		, xmppPassword = formPassword f
-			, xmppPassword = formPassword f
+		, xmppHostname = T.unpack $ strDomain $ jidDomain jid
-			, xmppHostname = h
+		, xmppPort = 5222
+		, xmppJID = formJID f
+		}
+
+testXMPP :: XMPPCreds -> IO (Either String XMPPCreds)
+testXMPP creds = do
+	(good, bad) <- partition (either (const False) (const True) . snd) 
+		<$> connectXMPP creds (const noop)
+	case good of
+		(((h, PortNumber p), _):_) -> return $ Right $ creds
+			{ xmppHostname = h
 			, xmppPort = fromIntegral p
-			, xmppJID = formJID f
 			}
-		_ -> testXMPP $ XMPPCreds
+		(((h, _), _):_) -> return $ Right $ creds
-			{ xmppUsername = username
+			{ xmppHostname = h
-			, xmppPassword = formPassword f
-			, xmppHostname = T.unpack $ strDomain $ jidDomain jid
-			, xmppPort = 5222
-			, xmppJID = formJID f
 			}
+		_ -> return $ Left $ intercalate "; " $ map formatlog bad
+  where
+  	formatlog ((h, p), Left e) = "host " ++ h ++ ":" ++ showport p ++ " failed: " ++ show e
+  	formatlog _ = ""
 
-testXMPP :: XMPPCreds -> IO (Either SomeException XMPPCreds)
+	showport (PortNumber n) = show n
-testXMPP creds = either Left (const $ Right creds)
+	showport (Service s) = s
-	<$> connectXMPP creds (const noop)
+	showport (UnixSocket s) = s
-
 #endif
 
-xmppPage :: Widget -> Handler RepHtml
+xmppPage :: Widget -> Handler Html
 xmppPage = page "Jabber" (Just Configuration)

Assistant/WebApp/Control.hs

@@ -20,11 +20,11 @@ import Control.Concurrent
 import System.Posix (getProcessID, signalProcess, sigTERM)
 import qualified Data.Map as M
 
-getShutdownR :: Handler RepHtml
+getShutdownR :: Handler Html
 getShutdownR = page "Shutdown" Nothing $
 	$(widgetFile "control/shutdown")
 
-getShutdownConfirmedR :: Handler RepHtml
+getShutdownConfirmedR :: Handler Html
 getShutdownConfirmedR = do
 	{- Remove all alerts for currently running activities. -}
 	liftAssistant $ do
@@ -45,7 +45,7 @@ getShutdownConfirmedR = do
 		$(widgetFile "control/shutdownconfirmed")
 
 {- Quite a hack, and doesn't redirect the browser window. -}
-getRestartR :: Handler RepHtml
+getRestartR :: Handler Html
 getRestartR = page "Restarting" Nothing $ do
 	void $ liftIO $ forkIO $ do
 		threadDelay 2000000
@@ -54,7 +54,7 @@ getRestartR = page "Restarting" Nothing $ do
 			error "restart failed"
 	$(widgetFile "control/restarting")
   where
-	restartcommand program = program ++ " assistant --stop; " ++
+	restartcommand program = program ++ " assistant --stop; exec " ++
 		program ++ " webapp"
 
 getRestartThreadR :: ThreadName -> Handler ()
@@ -63,7 +63,7 @@ getRestartThreadR name = do
 	liftIO $ maybe noop snd $ M.lookup name m
 	redirectBack
 
-getLogR :: Handler RepHtml
+getLogR :: Handler Html
 getLogR = page "Logs" Nothing $ do
 	logfile <- liftAnnex $ fromRepo gitAnnexLogFile
 	logs <- liftIO $ listLogs logfile

Assistant/WebApp/DashBoard.hs

@@ -23,15 +23,15 @@ import Types.Key
 import qualified Remote
 import qualified Git
 
-import Text.Hamlet
+import qualified Text.Hamlet as Hamlet
 import qualified Data.Map as M
 import Control.Concurrent
 
 {- A display of currently running and queued transfers. -}
 transfersDisplay :: Bool -> Widget
 transfersDisplay warnNoScript = do
-	webapp <- lift getYesod
+	webapp <- liftH getYesod
-	current <- lift $ M.toList <$> getCurrentTransfers
+	current <- liftH $ M.toList <$> getCurrentTransfers
 	queued <- take 10 <$> liftAssistant getTransferQueue
 	autoUpdate ident NotifierTransfersR (10 :: Int) (10 :: Int)
 	let transfers = simplifyTransfers $ current ++ queued
@@ -62,12 +62,12 @@ simplifyTransfers (v@(t1, _):r@((t2, _):l))
  - body is. To get the widget head content, the widget is also 
  - inserted onto the getDashboardR page.
  -}
-getTransfersR :: NotificationId -> Handler RepHtml
+getTransfersR :: NotificationId -> Handler Html
 getTransfersR nid = do
 	waitNotifier getTransferBroadcaster nid
 
 	p <- widgetToPageContent $ transfersDisplay False
-	hamletToRepHtml $ [hamlet|^{pageBody p}|]
+	giveUrlRenderer $ [hamlet|^{pageBody p}|]
 
 {- The main dashboard. -}
 dashboard :: Bool -> Widget
@@ -77,7 +77,7 @@ dashboard warnNoScript = do
 	let transferlist = transfersDisplay warnNoScript
 	$(widgetFile "dashboard/main")
 
-getDashboardR :: Handler RepHtml
+getDashboardR :: Handler Html
 getDashboardR = ifM (inFirstRun)
 	( redirect ConfigurationR
 	, page "" (Just DashBoard) $ dashboard True
@@ -88,16 +88,16 @@ headDashboardR :: Handler ()
 headDashboardR = noop
 
 {- Same as DashboardR, except no autorefresh at all (and no noscript warning). -}
-getNoScriptR :: Handler RepHtml
+getNoScriptR :: Handler Html
 getNoScriptR = page "" (Just DashBoard) $ dashboard False
 
 {- Same as DashboardR, except with autorefreshing via meta refresh. -}
-getNoScriptAutoR :: Handler RepHtml
+getNoScriptAutoR :: Handler Html
 getNoScriptAutoR = page "" (Just DashBoard) $ do
 	let ident = NoScriptR
 	let delayseconds = 3 :: Int
 	let this = NoScriptAutoR
-	toWidgetHead $(hamletFile $ hamletTemplate "dashboard/metarefresh")
+	toWidgetHead $(Hamlet.hamletFile $ hamletTemplate "dashboard/metarefresh")
 	dashboard False
 
 {- The javascript code does a post. -}

Assistant/WebApp/Documentation.hs

@@ -5,7 +5,7 @@
  - Licensed under the GNU AGPL version 3 or higher.
  -}
 
-{-# LANGUAGE TypeFamilies, QuasiQuotes, MultiParamTypeClasses, TemplateHaskell, OverloadedStrings, RankNTypes #-}
+{-# LANGUAGE QuasiQuotes, TemplateHaskell, OverloadedStrings #-}
 
 module Assistant.WebApp.Documentation where
 
@@ -21,12 +21,12 @@ licenseFile = do
 	base <- standaloneAppBase
 	return $ (</> "LICENSE") <$> base
 
-getAboutR :: Handler RepHtml
+getAboutR :: Handler Html
 getAboutR = page "About git-annex" (Just About) $ do
 	builtinlicense <- isJust <$> liftIO licenseFile
 	$(widgetFile "documentation/about")
 
-getLicenseR :: Handler RepHtml
+getLicenseR :: Handler Html
 getLicenseR = do
 	v <- liftIO licenseFile
 	case v of
@@ -37,6 +37,6 @@ getLicenseR = do
 			license <- liftIO $ readFile f
 			$(widgetFile "documentation/license")
 
-getRepoGroupR :: Handler RepHtml
+getRepoGroupR :: Handler Html
 getRepoGroupR = page "About repository groups" (Just About) $ do
 	$(widgetFile "documentation/repogroup")

Assistant/WebApp/Form.hs

@@ -8,10 +8,12 @@
 {-# LANGUAGE FlexibleContexts, TypeFamilies, QuasiQuotes #-}
 {-# LANGUAGE MultiParamTypeClasses, TemplateHaskell #-}
 {-# LANGUAGE OverloadedStrings, RankNTypes #-}
+{-# LANGUAGE CPP #-}
 
 module Assistant.WebApp.Form where
 
 import Types.Remote (RemoteConfigKey)
+import Assistant.WebApp.Types
 
 import Yesod hiding (textField, passwordField)
 import Yesod.Form.Fields as F
@@ -24,15 +26,22 @@ import Data.Text (Text)
  -
  - Required fields are still checked by Yesod.
  -}
-textField :: RenderMessage master FormMessage => Field sub master Text
+textField :: MkField Text
 textField = F.textField
 	{ fieldView = \theId name attrs val _isReq -> [whamlet|
 <input id="#{theId}" name="#{name}" *{attrs} type="text" value="#{either id id val}">
 |]
 	}
 
+readonlyTextField :: MkField Text
+readonlyTextField = F.textField
+	{ fieldView = \theId name attrs val _isReq -> [whamlet|
+<input id="#{theId}" name="#{name}" *{attrs} type="text" value="#{either id id val}" readonly="true">
+|]
+	}
+
 {- Also without required attribute. -}
-passwordField :: RenderMessage master FormMessage => Field sub master Text
+passwordField :: MkField Text
 passwordField = F.passwordField
 	{ fieldView = \theId name attrs val _isReq -> toWidget [hamlet|
 <input id="#{theId}" name="#{name}" *{attrs} type="password" value="#{either id id val}">
@@ -40,7 +49,11 @@ passwordField = F.passwordField
 	}
 
 {- Makes a note widget be displayed after a field. -}
+#if MIN_VERSION_yesod(1,2,0)
+withNote :: (Monad m, ToWidget (HandlerSite m) a) => Field m v -> a -> Field m v
+#else
 withNote :: Field sub master v -> GWidget sub master () -> Field sub master v
+#endif
 withNote field note = field { fieldView = newview }
   where
 	newview theId name attrs val isReq = 
@@ -48,7 +61,11 @@ withNote field note = field { fieldView = newview }
 		in [whamlet|^{fieldwidget}&nbsp;&nbsp;<span>^{note}</span>|]
 
 {- Note that the toggle string must be unique on the form. -}
+#if MIN_VERSION_yesod(1,2,0)
+withExpandableNote :: (Monad m, ToWidget (HandlerSite m) w) => Field m v -> (String, w) -> Field m v
+#else
 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}">
   #{toggle}
@@ -62,7 +79,11 @@ data EnableEncryption = SharedEncryption | NoEncryption
 	deriving (Eq)
 
 {- Adds a check box to an AForm to control encryption. -}
+#if MIN_VERSION_yesod(1,2,0)
+enableEncryptionField :: (RenderMessage site FormMessage) => AForm (HandlerT site IO) EnableEncryption
+#else
 enableEncryptionField :: RenderMessage master FormMessage => AForm sub master EnableEncryption
+#endif
 enableEncryptionField = areq (selectFieldList choices) "Encryption" (Just SharedEncryption)
   where
 	choices :: [(Text, EnableEncryption)]

Assistant/WebApp/Notifications.hs

@@ -5,7 +5,7 @@
  - Licensed under the GNU AGPL version 3 or higher.
  -}
 
-{-# LANGUAGE CPP, TypeFamilies, QuasiQuotes, MultiParamTypeClasses, TemplateHaskell, OverloadedStrings, RankNTypes #-}
+{-# LANGUAGE CPP, QuasiQuotes, TemplateHaskell, OverloadedStrings #-}
 
 #if defined VERSION_yesod_default
 #if ! MIN_VERSION_yesod_default(1,1,0)
@@ -23,7 +23,6 @@ import Assistant.Types.Buddies
 import Utility.NotificationBroadcaster
 import Utility.Yesod
 
-import Yesod
 import Data.Text (Text)
 import qualified Data.Text as T
 #ifndef WITH_OLD_YESOD

Assistant/WebApp/OtherRepos.hs

@@ -5,7 +5,7 @@
  - Licensed under the GNU AGPL version 3 or higher.
  -}
 
-{-# LANGUAGE CPP, TypeFamilies, QuasiQuotes, MultiParamTypeClasses, TemplateHaskell, OverloadedStrings, RankNTypes #-}
+{-# LANGUAGE QuasiQuotes, TemplateHaskell, OverloadedStrings #-}
 
 module Assistant.WebApp.OtherRepos where
 
@@ -18,11 +18,10 @@ import Config.Files
 import qualified Utility.Url as Url
 import Utility.Yesod
 
-import Yesod
 import Control.Concurrent
 import System.Process (cwd)
 
-getRepositorySwitcherR :: Handler RepHtml
+getRepositorySwitcherR :: Handler Html
 getRepositorySwitcherR = page "Switch repository" Nothing $ do
 	repolist <- liftIO listOtherRepos
 	$(widgetFile "control/repositoryswitcher")
@@ -40,9 +39,10 @@ listOtherRepos = do
  - 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 RepHtml
+getSwitchToRepositoryR :: FilePath -> Handler Html
 getSwitchToRepositoryR repo = do
 	liftIO $ startAssistant repo
+	liftIO $ addAutoStartFile repo -- make this the new default repo
 	redirect =<< liftIO geturl
   where
 	geturl = do

Assistant/WebApp/Page.hs

@@ -15,8 +15,7 @@ import Assistant.WebApp.Types
 import Assistant.WebApp.SideBar
 import Utility.Yesod
 
-import Yesod
+import qualified Text.Hamlet as Hamlet
-import Text.Hamlet
 import Data.Text (Text)
 
 data NavBarItem = DashBoard | Configuration | About
@@ -43,14 +42,14 @@ selectNavBar = ifM (inFirstRun) (return firstRunNavBar, return defaultNavBar)
 
 {- A standard page of the webapp, with a title, a sidebar, and that may
  - be highlighted on the navbar. -}
-page :: Html -> Maybe NavBarItem -> Widget -> Handler RepHtml
+page :: Hamlet.Html -> Maybe NavBarItem -> Widget -> Handler Html
 page title navbaritem content = customPage navbaritem $ do
 	setTitle title
 	sideBarDisplay
 	content
 
 {- A custom page, with no title or sidebar set. -}
-customPage :: Maybe NavBarItem -> Widget -> Handler RepHtml
+customPage :: Maybe NavBarItem -> Widget -> Handler Html
 customPage navbaritem content = do
 	webapp <- getYesod
 	navbar <- map navdetails <$> selectNavBar
@@ -62,7 +61,7 @@ customPage navbaritem content = do
 		addScript $ StaticR js_bootstrap_modal_js
 		addScript $ StaticR js_bootstrap_collapse_js
 		$(widgetFile "page")
-	hamletToRepHtml $(hamletFile $ hamletTemplate "bootstrap")
+	giveUrlRenderer $(Hamlet.hamletFile $ hamletTemplate "bootstrap")
   where
 	navdetails i = (navBarName i, navBarRoute i, Just i == navbaritem)
 

Assistant/WebApp/RepoList.hs

@@ -5,7 +5,7 @@
  - Licensed under the GNU AGPL version 3 or higher.
  -}
 
-{-# LANGUAGE TypeFamilies, QuasiQuotes, MultiParamTypeClasses, TemplateHaskell, OverloadedStrings, RankNTypes, CPP #-}
+{-# LANGUAGE QuasiQuotes, TemplateHaskell, OverloadedStrings, CPP #-}
 
 module Assistant.WebApp.RepoList where
 
@@ -13,6 +13,7 @@ import Assistant.WebApp.Common
 import Assistant.DaemonStatus
 import Assistant.WebApp.Notifications
 import Assistant.WebApp.Utility
+import Assistant.Ssh
 import qualified Annex
 import qualified Remote
 import qualified Types.Remote as Remote
@@ -22,6 +23,8 @@ import Logs.Remote
 import Logs.Trust
 import Logs.Group
 import Config
+import Git.Config
+import Assistant.Sync
 import Config.Cost
 import qualified Git
 #ifdef WITH_XMPP
@@ -79,11 +82,11 @@ notWanted _ = False
  -
  - Returns a div, which will be inserted into the calling page.
  -}
-getRepoListR :: RepoListNotificationId -> Handler RepHtml
+getRepoListR :: RepoListNotificationId -> Handler Html
 getRepoListR (RepoListNotificationId nid reposelector) = do
 	waitNotifier getRepoListBroadcaster nid
 	p <- widgetToPageContent $ repoListDisplay reposelector
-	hamletToRepHtml $ [hamlet|^{pageBody p}|]
+	giveUrlRenderer $ [hamlet|^{pageBody p}|]
 
 mainRepoSelector :: RepoSelector
 mainRepoSelector = RepoSelector
@@ -110,13 +113,14 @@ repoListDisplay reposelector = do
 	addScript $ StaticR jquery_ui_mouse_js
 	addScript $ StaticR jquery_ui_sortable_js
 
-	repolist <- lift $ repoList reposelector
+	repolist <- liftH $ repoList reposelector
 	let addmore = nudgeAddMore reposelector
 	let nootherrepos = length repolist < 2
 
 	$(widgetFile "repolist")
   where
 	ident = "repolist"
+	unfinished uuid = uuid == NoUUID
 
 type RepoList = [(String, UUID, Actions)]
 
@@ -222,3 +226,30 @@ reorderCosts remote rs = zip rs'' (insertCostAfter costs i)
 	rs' = filter (\r -> Remote.uuid r /= Remote.uuid remote) rs
 	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

@@ -5,7 +5,7 @@
  - Licensed under the GNU AGPL version 3 or higher.
  -}
 
-{-# LANGUAGE TypeFamilies, QuasiQuotes, MultiParamTypeClasses, TemplateHaskell, OverloadedStrings, RankNTypes #-}
+{-# LANGUAGE QuasiQuotes, TemplateHaskell, OverloadedStrings #-}
 
 module Assistant.WebApp.SideBar where
 
@@ -18,7 +18,6 @@ import Assistant.DaemonStatus
 import Utility.NotificationBroadcaster
 import Utility.Yesod
 
-import Yesod
 import Data.Text (Text)
 import qualified Data.Text as T
 import qualified Data.Map as M
@@ -28,7 +27,7 @@ sideBarDisplay :: Widget
 sideBarDisplay = do
 	let content = do
 		{- Add newest alerts to the sidebar. -}
-		alertpairs <- lift $ M.toList . alertMap
+		alertpairs <- liftH $ M.toList . alertMap
 			<$> liftAssistant getDaemonStatus
 		mapM_ renderalert $
 			take displayAlerts $ reverse $ sortAlertPairs alertpairs
@@ -61,7 +60,7 @@ sideBarDisplay = do
  - body is. To get the widget head content, the widget is also 
  - inserted onto all pages.
  -}
-getSideBarR :: NotificationId -> Handler RepHtml
+getSideBarR :: NotificationId -> Handler Html
 getSideBarR nid = do
 	waitNotifier getAlertBroadcaster nid
 
@@ -73,7 +72,7 @@ getSideBarR nid = do
 	liftIO $ threadDelay 100000
 
 	page <- widgetToPageContent sideBarDisplay
-	hamletToRepHtml $ [hamlet|^{pageBody page}|]
+	giveUrlRenderer $ [hamlet|^{pageBody page}|]
 
 {- Called by the client to close an alert. -}
 getCloseAlert :: AlertId -> Handler ()
@@ -92,7 +91,7 @@ getClickAlert i = do
 			redirect $ buttonUrl b
 		_ -> redirectBack
 
-htmlIcon :: AlertIcon -> GWidget WebApp WebApp ()
+htmlIcon :: AlertIcon -> Widget
 htmlIcon ActivityIcon = [whamlet|<img src="@{StaticR activityicon_gif}" alt="">|]
 htmlIcon SyncIcon = [whamlet|<img src="@{StaticR syncicon_gif}" alt="">|]
 htmlIcon InfoIcon = bootstrapIcon "info-sign"
@@ -101,5 +100,5 @@ htmlIcon ErrorIcon = bootstrapIcon "exclamation-sign"
 -- utf-8 umbrella (utf-8 cloud looks too stormy)
 htmlIcon TheCloud = [whamlet|&#9730;|]
 
-bootstrapIcon :: Text -> GWidget sub master ()
+bootstrapIcon :: Text -> Widget
 bootstrapIcon name = [whamlet|<i .icon-#{name}></i>|]

Assistant/WebApp/Types.hs

@@ -7,7 +7,8 @@
 
 {-# LANGUAGE TypeFamilies, QuasiQuotes, MultiParamTypeClasses #-}
 {-# LANGUAGE TemplateHaskell, OverloadedStrings, RankNTypes #-}
-{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleInstances, FlexibleContexts #-}
+{-# LANGUAGE CPP #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
 module Assistant.WebApp.Types where
@@ -22,7 +23,6 @@ import Utility.Yesod
 import Logs.Transfer
 import Build.SysConfig (packageversion)
 
-import Yesod
 import Yesod.Static
 import Text.Hamlet
 import Data.Text (Text, pack, unpack)
@@ -71,7 +71,7 @@ instance Yesod WebApp where
 			addStylesheet $ StaticR css_bootstrap_css
 			addStylesheet $ StaticR css_bootstrap_responsive_css
 			$(widgetFile "error")
-		hamletToRepHtml $(hamletFile $ hamletTemplate "bootstrap")
+		giveUrlRenderer $(hamletFile $ hamletTemplate "bootstrap")
 
 instance RenderMessage WebApp FormMessage where
 	renderMessage _ _ = defaultFormMessage
@@ -81,29 +81,65 @@ instance RenderMessage WebApp FormMessage where
  - When the webapp is run outside a git-annex repository, the fallback
  - value is returned.
  -}
+#if MIN_VERSION_yesod(1,2,0)
+liftAnnexOr :: forall a. a -> Annex a -> Handler a
+#else
 liftAnnexOr :: forall sub a. a -> Annex a -> GHandler sub WebApp a
+#endif
 liftAnnexOr fallback a = ifM (noAnnex <$> getYesod)
 	( return fallback
 	, liftAssistant $ liftAnnex a
 	)
 
+#if MIN_VERSION_yesod(1,2,0)
+instance LiftAnnex Handler where
+#else
 instance LiftAnnex (GHandler sub WebApp) where
-	liftAnnex = liftAnnexOr $ error "internal runAnnex"
+#endif
+	liftAnnex = liftAnnexOr $ error "internal liftAnnex"
 
+#if MIN_VERSION_yesod(1,2,0)
+instance LiftAnnex (WidgetT WebApp IO) where
+#else
 instance LiftAnnex (GWidget WebApp WebApp) where
-	liftAnnex = lift . liftAnnex
+#endif
+	liftAnnex = liftH . liftAnnex
 
 class LiftAssistant m where
 	liftAssistant :: Assistant a -> m a
 
+#if MIN_VERSION_yesod(1,2,0)
+instance LiftAssistant Handler where
+#else
 instance LiftAssistant (GHandler sub WebApp) where
+#endif
 	liftAssistant a = liftIO . flip runAssistant a
 		=<< assistantData <$> getYesod
 
+#if MIN_VERSION_yesod(1,2,0)
+instance LiftAssistant (WidgetT WebApp IO) where
+#else
 instance LiftAssistant (GWidget WebApp WebApp) where
-	liftAssistant = lift . liftAssistant
+#endif
+	liftAssistant = liftH . liftAssistant
 
-type Form x = Html -> MForm WebApp WebApp (FormResult x, Widget)
+#if MIN_VERSION_yesod(1,2,0)
+type MkMForm x = MForm Handler (FormResult x, Widget)
+#else
+type MkMForm x = MForm WebApp WebApp (FormResult x, Widget)
+#endif
+
+#if MIN_VERSION_yesod(1,2,0)
+type MkAForm x = AForm Handler x
+#else
+type MkAForm x = AForm WebApp WebApp x
+#endif
+
+#if MIN_VERSION_yesod(1,2,0)
+type MkField x = Monad m => RenderMessage (HandlerSite m) FormMessage => Field m x
+#else
+type MkField x = RenderMessage master FormMessage => Field sub master x
+#endif
 
 data RepoSelector = RepoSelector
 	{ onlyCloud :: Bool

Assistant/WebApp/routes

@@ -32,6 +32,8 @@
 /config/repository/edit/new/cloud/#UUID EditNewCloudRepositoryR GET POST
 /config/repository/sync/disable/#UUID DisableSyncR GET
 /config/repository/sync/enable/#UUID EnableSyncR GET
+/config/repository/unfinished/check CheckUnfinishedRepositoriesR GET
+/config/repository/unfinished/retry RetryUnfinishedRepositoriesR GET
 
 /config/repository/add/drive AddDriveR GET POST
 /config/repository/add/drive/confirm/#RemovableDrive ConfirmAddDriveR GET

Assistant/XMPP.hs

@@ -1,6 +1,6 @@
 {- core xmpp support
  -
- - Copyright 2012 Joey Hess <joey@kitenet.net>
+ - Copyright 2012-2013 Joey Hess <joey@kitenet.net>
  -
  - Licensed under the GNU GPL version 3 or higher.
  -}
@@ -12,6 +12,7 @@ module Assistant.XMPP where
 import Assistant.Common
 import Assistant.Types.NetMessager
 import Assistant.Pairing
+import Git.Sha (extractSha)
 
 import Network.Protocol.XMPP hiding (Node)
 import Data.Text (Text)
@@ -74,15 +75,33 @@ gitAnnexTagInfo v = case extractGitAnnexTag v of
 		<*> pure tag
 	_ -> Nothing
 
-{- A presence with a git-annex tag in it. -}
+{- A presence with a git-annex tag in it.
+ - Also includes a status tag, which may be visible in XMPP clients. -}
 gitAnnexPresence :: Element -> Presence
-gitAnnexPresence = insertGitAnnexTag $ emptyPresence PresenceAvailable
+gitAnnexPresence = insertGitAnnexTag $ addStatusTag $ emptyPresence PresenceAvailable
+  where
+	addStatusTag p = p
+		{ presencePayloads = status : presencePayloads p }
+	status = Element "status" [] [statusMessage]
+	statusMessage = NodeContent $ ContentText $ T.pack "git-annex"
 
 {- A presence with an empty git-annex tag in it, used for letting other
  - clients know we're around and are a git-annex client. -}
 gitAnnexSignature :: Presence
 gitAnnexSignature = gitAnnexPresence $ Element gitAnnexTagName [] []
 
+{- XMPP client to server ping -}
+xmppPing :: JID -> IQ
+xmppPing selfjid = (emptyIQ IQGet)
+	{ iqID = Just "c2s1"
+	, iqFrom = Just selfjid
+	, iqTo = Just $ JID Nothing (jidDomain selfjid) Nothing
+	, iqPayload = Just $ Element xmppPingTagName [] []
+	}
+
+xmppPingTagName :: Name
+xmppPingTagName = "{urn:xmpp}ping"
+
 {- A message with a git-annex tag in it. -}
 gitAnnexMessage :: Element -> JID -> JID -> Message
 gitAnnexMessage elt tojid fromjid = (insertGitAnnexTag silentMessage elt)
@@ -131,8 +150,9 @@ decodePairingNotification m = parse . words . T.unpack . tagValue
 pushMessage :: PushStage -> JID -> JID -> Message
 pushMessage = gitAnnexMessage . encode
   where
-	encode (CanPush u) =
+	encode (CanPush u shas) =
-		gitAnnexTag canPushAttr $ T.pack $ fromUUID u
+		gitAnnexTag canPushAttr $ T.pack $ unwords $
+			fromUUID u : map show shas
 	encode (PushRequest u) =
 		gitAnnexTag pushRequestAttr $ T.pack $ fromUUID u
 	encode (StartingPush u) =
@@ -160,7 +180,7 @@ decodeMessage m = decode =<< gitAnnexTagInfo m
 		, receivePackDoneAttr
 		]
 		[ decodePairingNotification
-		, pushdecoder $ gen CanPush
+		, pushdecoder $ shasgen CanPush
 		, pushdecoder $ gen PushRequest
 		, pushdecoder $ gen StartingPush
 		, pushdecoder $ seqgen ReceivePackOutput
@@ -172,11 +192,14 @@ decodeMessage m = decode =<< gitAnnexTagInfo m
 	pushdecoder a m' i = Pushing
 		<$> (formatJID <$> messageFrom m')
 		<*> a i
-	gen c = Just . c . toUUID . T.unpack . tagValue
+	gen c i = c . toUUID <$> headMaybe (words (T.unpack (tagValue i)))
 	seqgen c i = do
 	  	packet <- decodeTagContent $ tagElement i
 		let seqnum = fromMaybe 0 $ readish $ T.unpack $ tagValue i
 		return $ c seqnum packet
+	shasgen c i = do
+		let (u:shas) = words $ T.unpack $ tagValue i
+		return $ c (toUUID u) (mapMaybe extractSha shas)
 
 decodeExitCode :: Int -> ExitCode
 decodeExitCode 0 = ExitSuccess
@@ -245,3 +268,6 @@ sendPackAttr = "sp"
 
 receivePackDoneAttr :: Name
 receivePackDoneAttr = "rpdone"
+
+shasAttr :: Name
+shasAttr = "shas"

Assistant/XMPP/Client.hs

@@ -27,36 +27,46 @@ data XMPPCreds = XMPPCreds
 	}
 	deriving (Read, Show)
 
-connectXMPP :: XMPPCreds -> (JID -> XMPP a) -> IO (Either SomeException ())
+connectXMPP :: XMPPCreds -> (JID -> XMPP a) -> IO [(HostPort, Either SomeException ())]
 connectXMPP c a = case parseJID (xmppJID c) of
 	Nothing -> error "bad JID"
 	Just jid -> connectXMPP' jid c a
 
 {- Do a SRV lookup, but if it fails, fall back to the cached xmppHostname. -}
-connectXMPP' :: JID -> XMPPCreds -> (JID -> XMPP a) -> IO (Either SomeException ())
+connectXMPP' :: JID -> XMPPCreds -> (JID -> XMPP a) -> IO [(HostPort, Either SomeException ())]
-connectXMPP' jid c a = go =<< lookupSRV srvrecord
+connectXMPP' jid c a = reverse <$> (handle =<< lookupSRV srvrecord)
   where
 	srvrecord = mkSRVTcp "xmpp-client" $
 		T.unpack $ strDomain $ jidDomain jid
 	serverjid = JID Nothing (jidDomain jid) Nothing
 
-	go [] = run (xmppHostname c)
+	handle [] = do
-			(PortNumber $ fromIntegral $ xmppPort c)
+		let h = xmppHostname c
-			(a jid)
+		let p = PortNumber $ fromIntegral $ xmppPort c
-	go ((h,p):rest) = do
+		r <- run h p $ a jid
+		return [r]
+	handle srvs = go [] srvs
+
+	go l [] = return l
+	go l ((h,p):rest) = do
 		{- Try each SRV record in turn, until one connects,
 		 - at which point the MVar will be full. -}
 		mv <- newEmptyMVar
 		r <- run h p $ do
 			liftIO $ putMVar mv ()
 			a jid
-		ifM (isEmptyMVar mv) (go rest, return r)
+		ifM (isEmptyMVar mv)
+			( go (r : l) rest
+			, return (r : l)
+			)
 
 	{- Async exceptions are let through so the XMPP thread can
 	 - be killed. -}
-	run h p a' = tryNonAsync $
+	run h p a' = do
-		runClientError (Server serverjid h p) jid
+		r <- tryNonAsync $
-			(xmppUsername c) (xmppPassword c) (void a')
+			runClientError (Server serverjid h p) jid
+				(xmppUsername c) (xmppPassword c) (void a')
+		return ((h, p), r)
 
 {- XMPP runClient, that throws errors rather than returning an Either -}
 runClientError :: Server -> JID -> T.Text -> T.Text -> XMPP a -> IO a

Assistant/XMPP/Git.hs

@@ -23,6 +23,7 @@ import qualified Annex.Branch
 import Annex.UUID
 import Logs.UUID
 import Annex.TaggedPush
+import Annex.CatFile
 import Config
 import Git
 import qualified Git.Branch
@@ -43,6 +44,22 @@ import System.Timeout
 import qualified Data.ByteString as B
 import qualified Data.Map as M
 
+{- Largest chunk of data to send in a single XMPP message. -}
+chunkSize :: Int
+chunkSize = 4096
+
+{- How long to wait for an expected message before assuming the other side
+ - has gone away and canceling a push. 
+ -
+ - This needs to be long enough to allow a message of up to 2+ times
+ - chunkSize to propigate up to a XMPP server, perhaps across to another
+ - server, and back down to us. On the other hand, other XMPP pushes can be
+ - delayed for running until the timeout is reached, so it should not be
+ - excessive.
+ -}
+xmppTimeout :: Int
+xmppTimeout = 120000000 -- 120 seconds
+
 finishXMPPPairing :: JID -> UUID -> Assistant ()
 finishXMPPPairing jid u = void $ alertWhile alert $
 	makeXMPPGitRemote buddy (baseJID jid) u
@@ -83,8 +100,8 @@ makeXMPPGitRemote buddyname jid u = do
  -
  - We listen at the other end of the pipe and relay to and from XMPP.
  -}
-xmppPush :: ClientID -> (Git.Repo -> IO Bool) -> (NetMessage -> Assistant ()) -> Assistant Bool
+xmppPush :: ClientID -> (Git.Repo -> IO Bool) -> Assistant Bool
-xmppPush cid gitpush handledeferred = runPush SendPack cid handledeferred $ do
+xmppPush cid gitpush = do
 	u <- liftAnnex getUUID
 	sendNetMessage $ Pushing cid (StartingPush u)
 
@@ -120,7 +137,8 @@ xmppPush cid gitpush handledeferred = runPush SendPack cid handledeferred $ do
 	liftIO $ do
 		mapM_ killThread [t1, t2]
 		mapM_ hClose [inh, outh, controlh]
-
+		mapM_ closeFd [Fd inf, Fd outf, Fd controlf]
+	
 	return r
   where
 	toxmpp seqnum inh = do
@@ -132,24 +150,26 @@ xmppPush cid gitpush handledeferred = runPush SendPack cid handledeferred $ do
 				sendNetMessage $ Pushing cid $
 					SendPackOutput seqnum' b
 				toxmpp seqnum' inh
-	fromxmpp outh controlh = forever $ do
+	
-		m <- timeout xmppTimeout <~> waitNetPushMessage SendPack
+	fromxmpp outh controlh = withPushMessagesInSequence cid SendPack handle
-		case m of
+	  where
-			(Just (Pushing _ (ReceivePackOutput _ b))) -> 
+	  	handle (Just (Pushing _ (ReceivePackOutput _ b))) = 
-				liftIO $ writeChunk outh b
+			liftIO $ writeChunk outh b
-			(Just (Pushing _ (ReceivePackDone exitcode))) ->
+		handle (Just (Pushing _ (ReceivePackDone exitcode))) =
-				liftIO $ do
+			liftIO $ do
-					hPrint controlh exitcode
+				hPrint controlh exitcode
-					hFlush controlh
+				hFlush controlh
-			(Just _) -> noop
+		handle (Just _) = noop
-			Nothing -> do
+		handle Nothing = do
-				debug ["timeout waiting for git receive-pack output via XMPP"]
+			debug ["timeout waiting for git receive-pack output via XMPP"]
-				-- Send a synthetic exit code to git-annex
+			-- Send a synthetic exit code to git-annex
-				-- xmppgit, which will exit and cause git push
+			-- xmppgit, which will exit and cause git push
-				-- to die.
+			-- to die.
-				liftIO $ do
+			liftIO $ do
-					hPrint controlh (ExitFailure 1)
+				hPrint controlh (ExitFailure 1)
-					hFlush controlh
+				hFlush controlh
+				killThread =<< myThreadId
+	
 	installwrapper tmpdir = liftIO $ do
 		createDirectoryIfMissing True tmpdir
 		let wrapper = tmpdir </> "git-remote-xmpp"
@@ -159,6 +179,7 @@ xmppPush cid gitpush handledeferred = runPush SendPack cid handledeferred $ do
 			, "exec " ++ program ++ " xmppgit"
 			]
 		modifyFileMode wrapper $ addModes executeModes
+	
 	{- Use GIT_ANNEX_TMP_DIR if set, since that may be a better temp
 	 - dir (ie, not on a crippled filesystem where we can't make
 	 - the wrapper executable). -}
@@ -169,7 +190,6 @@ xmppPush cid gitpush handledeferred = runPush SendPack cid handledeferred $ do
 				tmp <- liftAnnex $ fromRepo gitAnnexTmpDir
 				return $ tmp </> "xmppgit"
 			Just d -> return $ d </> "xmppgit"
-				
 
 type EnvVar = String
 
@@ -219,8 +239,8 @@ xmppGitRelay = do
 
 {- Relays git receive-pack stdin and stdout via XMPP, as well as propigating
  - its exit status to XMPP. -}
-xmppReceivePack :: ClientID -> (NetMessage -> Assistant ()) -> Assistant Bool
+xmppReceivePack :: ClientID -> Assistant Bool
-xmppReceivePack cid handledeferred = runPush ReceivePack cid handledeferred $ do
+xmppReceivePack cid = do
 	repodir <- liftAnnex $ fromRepo repoPath
 	let p = (proc "git" ["receive-pack", repodir])
 		{ std_in = CreatePipe
@@ -245,19 +265,17 @@ xmppReceivePack cid handledeferred = runPush ReceivePack cid handledeferred $ do
 			let seqnum' = succ seqnum
 			sendNetMessage $ Pushing cid $ ReceivePackOutput seqnum' b
 			relaytoxmpp seqnum' outh
-	relayfromxmpp inh = forever $ do
+	relayfromxmpp inh = withPushMessagesInSequence cid ReceivePack handle
-		m <- timeout xmppTimeout <~> waitNetPushMessage ReceivePack
+	  where
-		case m of
+	  	handle (Just (Pushing _ (SendPackOutput _ b))) =
-			(Just (Pushing _ (SendPackOutput _ b))) ->
+			liftIO $ writeChunk inh b
-				liftIO $ writeChunk inh b
+		handle (Just _) = noop
-			(Just _) -> noop
+		handle Nothing = do
-			Nothing -> do
+			debug ["timeout waiting for git send-pack output via XMPP"]
-				debug ["timeout waiting for git send-pack output via XMPP"]
+			-- closing the handle will make git receive-pack exit
-				-- closing the handle will make
+			liftIO $ do
-				-- git receive-pack exit
+				hClose inh
-				liftIO $ do
+				killThread =<< myThreadId
-					hClose inh
-					killThread =<< myThreadId
 
 xmppRemotes :: ClientID -> UUID -> Assistant [Remote]
 xmppRemotes cid theiruuid = case baseJID <$> parseJID cid of
@@ -271,15 +289,12 @@ xmppRemotes cid theiruuid = case baseJID <$> parseJID cid of
 	matching loc r = repoIsUrl r && repoLocation r == loc
 	knownuuid um r = Remote.uuid r == theiruuid || M.member theiruuid um
 
-handlePushInitiation :: (Remote -> Assistant ()) -> NetMessage -> Assistant ()
+{- Returns the ClientID that it pushed to. -}
-handlePushInitiation _ (Pushing cid (CanPush theiruuid)) =
+runPush :: (Remote -> Assistant ()) -> NetMessage -> Assistant (Maybe ClientID)
-	unlessM (null <$> xmppRemotes cid theiruuid) $ do
+runPush checkcloudrepos (Pushing cid (PushRequest theiruuid)) =
-		u <- liftAnnex getUUID
-		sendNetMessage $ Pushing cid (PushRequest u)
-handlePushInitiation checkcloudrepos (Pushing cid (PushRequest theiruuid)) =
 	go =<< liftAnnex (inRepo Git.Branch.current)
   where
-	go Nothing = noop
+	go Nothing = return Nothing
 	go (Just branch) = do
 		rs <- xmppRemotes cid theiruuid
 		liftAnnex $ Annex.Branch.commit "update"
@@ -288,40 +303,80 @@ handlePushInitiation checkcloudrepos (Pushing cid (PushRequest theiruuid)) =
 			<*> getUUID
 		liftIO $ Command.Sync.updateBranch (Command.Sync.syncBranch branch) g
 		selfjid <- ((T.unpack <$>) . xmppClientID) <$> getDaemonStatus
-		forM_ rs $ \r -> do
+		if null rs
-			void $ alertWhile (syncAlert [r]) $
+			then return Nothing
-				xmppPush cid
+			else do
-					(taggedPush u selfjid branch r)
+				forM_ rs $ \r -> do
-					(handleDeferred checkcloudrepos)
+					void $ alertWhile (syncAlert [r]) $
-			checkcloudrepos r
+						xmppPush cid (taggedPush u selfjid branch r)
-handlePushInitiation checkcloudrepos (Pushing cid (StartingPush theiruuid)) = do
+					checkcloudrepos r
+				return $ Just cid
+runPush checkcloudrepos (Pushing cid (StartingPush theiruuid)) = do
 	rs <- xmppRemotes cid theiruuid
-	unless (null rs) $ do
+	if null rs
-		void $ alertWhile (syncAlert rs) $
+		then return Nothing
-			xmppReceivePack cid (handleDeferred checkcloudrepos)
+		else do
-		mapM_ checkcloudrepos rs
+			void $ alertWhile (syncAlert rs) $
-handlePushInitiation _ _ = noop
+				xmppReceivePack cid
+			mapM_ checkcloudrepos rs
+			return $ Just cid
+runPush _ _ = return Nothing
 
-handleDeferred :: (Remote -> Assistant ()) -> NetMessage -> Assistant ()
+{- Check if any of the shas that can be pushed are ones we do not
-handleDeferred = handlePushInitiation
+ - have.
+ -
+ - (Older clients send no shas, so when there are none, always
+ - request a push.)
+ -}
+handlePushNotice :: NetMessage -> Assistant ()
+handlePushNotice (Pushing cid (CanPush theiruuid shas)) =
+	unlessM (null <$> xmppRemotes cid theiruuid) $
+		if null shas
+			then go
+			else ifM (haveall shas)
+				( debug ["ignoring CanPush with known shas"]
+				, go
+				)
+  where
+  	go = do
+		u <- liftAnnex getUUID
+		sendNetMessage $ Pushing cid (PushRequest u)
+	haveall l = liftAnnex $ not <$> anyM donthave l
+	donthave sha = isNothing <$> catObjectDetails sha
+handlePushNotice _ = noop
 
 writeChunk :: Handle -> B.ByteString -> IO ()
 writeChunk h b = do
 	B.hPut h b
 	hFlush h
 
-{- Largest chunk of data to send in a single XMPP message. -}
+{- Gets NetMessages for a PushSide, ensures they are in order,
-chunkSize :: Int
+ - and runs an action to handle each in turn. The action will be passed
-chunkSize = 4096
+ - Nothing on timeout.
-
-{- How long to wait for an expected message before assuming the other side
- - has gone away and canceling a push. 
  -
- - This needs to be long enough to allow a message of up to 2+ times
+ - Does not currently reorder messages, but does ensure that any 
- - chunkSize to propigate up to a XMPP server, perhaps across to another
+ - duplicate messages, or messages not in the sequence, are discarded.
- - server, and back down to us. On the other hand, other XMPP pushes can be
- - delayed for running until the timeout is reached, so it should not be
- - excessive.
  -}
-xmppTimeout :: Int
+withPushMessagesInSequence :: ClientID -> PushSide -> (Maybe NetMessage -> Assistant ()) -> Assistant ()
-xmppTimeout = 120000000 -- 120 seconds
+withPushMessagesInSequence cid side a = loop 0
+  where
+  	loop seqnum = do
+		m <- timeout xmppTimeout <~> waitInbox cid side
+	  	let go s = a m >> loop s
+		let next = seqnum + 1
+		case extractSequence =<< m of
+			Just seqnum'
+				| seqnum' == next -> go next
+				| seqnum' == 0 -> go seqnum
+				| seqnum' == seqnum -> do
+					debug ["ignoring duplicate sequence number", show seqnum]
+					loop seqnum
+				| otherwise -> do
+					debug ["ignoring out of order sequence number", show seqnum', "expected", show next]
+					loop seqnum
+			Nothing -> go seqnum
+
+extractSequence :: NetMessage -> Maybe Int
+extractSequence (Pushing _ (ReceivePackOutput seqnum _)) = Just seqnum
+extractSequence (Pushing _ (SendPackOutput seqnum _)) = Just seqnum
+extractSequence _ = Nothing

Backend/URL.hs

@@ -27,16 +27,18 @@ backend = Backend
 	, canUpgradeKey = Nothing
 	}
 
-fromUrl :: String -> Maybe Integer -> Key
+{- When it's not too long, use the full url as the key name.
-fromUrl url size = stubKey
+ - If the url is too long, it's truncated at half the filename length
-	{ keyName = key
+ - limit, and the md5 of the url is prepended to ensure a unique key. -}
-	, keyBackendName = "URL"
+fromUrl :: String -> Maybe Integer -> Annex Key
-	, keySize = size
+fromUrl url size = do
+	limit <- liftIO . fileNameLengthLimit =<< fromRepo gitAnnexDir
+	let truncurl = truncateFilePath (limit `div` 2) url
+	let key = if url == truncurl
+		then url
+		else truncurl ++ "-" ++ md5s (Str url)
+	return $ stubKey
+		{ keyName = key
+		, keyBackendName = "URL"
+		, keySize = size
 	}
-  where
-	{- when it's not too long, use the url as the key name
-	 - 256 is the absolute filename max, but use a shorter
-	 - length because this is not the entire key filename. -}
-	key
-		| length url < 128 = url
-		| otherwise = take 128 url ++ "-" ++ md5s (Str url)

Build/BundledPrograms.hs

@@ -40,6 +40,8 @@ bundledPrograms = catMaybes
 	, SysConfig.sha512
 	, SysConfig.sha224
 	, SysConfig.sha384
+	-- ionice is not included in the bundle; we rely on the system's
+	-- own version, which may better match its kernel
 	]
   where
 	ifset True s = Just s

Build/Configure.hs

@@ -31,6 +31,7 @@ tests =
 	, TestCase "curl" $ testCmd "curl" "curl --version >/dev/null"
 	, TestCase "wget" $ testCmd "wget" "wget --version >/dev/null"
 	, TestCase "bup" $ testCmd "bup" "bup --version >/dev/null"
+	, TestCase "ionice" $ testCmd "ionice" "ionice -c3 true >/dev/null"
 	, TestCase "gpg" $ maybeSelectCmd "gpg"
 		[ ("gpg", "--version >/dev/null")
 		, ("gpg2", "--version >/dev/null") ]

Build/DesktopFile.hs

@@ -1,4 +1,4 @@
-{- Generating and installing a desktop menu entry file
+{- Generating and installing a desktop menu entry file and icon,
  - and a desktop autostart file. (And OSX equivilants.)
  -
  - Copyright 2012 Joey Hess <joey@kitenet.net>
@@ -48,11 +48,14 @@ inDestDir f = do
 
 writeFDODesktop :: FilePath -> IO ()
 writeFDODesktop command = do
-	datadir <- ifM systemwideInstall ( return systemDataDir, userDataDir )
+	systemwide <- systemwideInstall
-	installMenu command
-		=<< inDestDir (desktopMenuFilePath "git-annex" datadir)
 
-	configdir <- ifM systemwideInstall ( return systemConfigDir, userConfigDir )
+	datadir <- if systemwide then return systemDataDir else userDataDir
+	menufile <- inDestDir (desktopMenuFilePath "git-annex" datadir)
+	icondir <- inDestDir (iconDir datadir)
+	installMenu command menufile "doc" icondir
+
+	configdir <- if systemwide then return systemConfigDir else userConfigDir
 	installAutoStart command 
 		=<< inDestDir (autoStartPath "git-annex" configdir)
 

Build/InstallDesktopFile.hs

@@ -1,4 +1,4 @@
-{- Generating and installing a desktop menu entry file
+{- Generating and installing a desktop menu entry file and icon,
  - and a desktop autostart file. (And OSX equivilants.)
  -
  - Copyright 2012 Joey Hess <joey@kitenet.net>

Build/NullSoftInstaller.hs

@@ -119,6 +119,7 @@ cygwinDlls :: [FilePath]
 cygwinDlls =
 	[ "cygwin1.dll"
 	, "cygasn1-8.dll"
+	, "cygattr-1.dll"
 	, "cygheimbase-1.dll"
 	, "cygroken-18.dll"
 	, "cygcom_err-2.dll"

CmdLine.hs

@@ -30,6 +30,7 @@ import Annex.Content
 import Annex.Ssh
 import Annex.Environment
 import Command
+import Types.Messages
 
 type Params = [String]
 type Flags = [Annex ()]
@@ -47,7 +48,11 @@ dispatch fuzzyok allargs allcmds commonoptions fields header getgitrepo = do
 				checkEnvironment
 				checkfuzzy
 				forM_ fields $ uncurry Annex.setField
+				when (cmdnomessages cmd) $ 
+					Annex.setOutput QuietOutput
 				sequence_ flags
+				whenM (annexDebug <$> Annex.getGitConfig) $
+					liftIO enableDebugOutput
 				prepCommand cmd params
 		 	tryRun state' cmd $ [startup] ++ actions ++ [shutdown $ cmdnocommit cmd]
   where

Command.hs

@@ -9,6 +9,7 @@ module Command (
 	command,
 	noRepo,
 	noCommit,
+	noMessages,
 	withOptions,
 	next,
 	stop,
@@ -40,13 +41,18 @@ import Annex.CheckAttr
 
 {- Generates a normal command -}
 command :: String -> String -> [CommandSeek] -> CommandSection -> String -> Command
-command = Command [] Nothing commonChecks False
+command = Command [] Nothing commonChecks False False
 
 {- Indicates that a command doesn't need to commit any changes to
  - the git-annex branch. -}
 noCommit :: Command -> Command
 noCommit c = c { cmdnocommit = True }
 
+{- Indicates that a command should not output anything other than what
+ - it directly sends to stdout. (--json can override this). -}
+noMessages :: Command -> Command
+noMessages c = c { cmdnomessages = True }
+
 {- Adds a fallback action to a command, that will be run if it's used
  - outside a git repository. -}
 noRepo :: IO () -> Command -> Command
@@ -99,7 +105,11 @@ isBareRepo :: Annex Bool
 isBareRepo = fromRepo Git.repoIsLocalBare
 
 numCopies :: FilePath  -> Annex (Maybe Int)
-numCopies file = readish <$> checkAttr "annex.numcopies" file
+numCopies file = do
+	forced <- Annex.getState Annex.forcenumcopies
+	case forced of
+		Just n -> return $ Just n
+		Nothing -> readish <$> checkAttr "annex.numcopies" file
 
 numCopiesCheck :: FilePath -> Key -> (Int -> Int -> Bool) -> Annex Bool
 numCopiesCheck file key vs = do

Command/Add.hs

@@ -31,6 +31,7 @@ import Config
 import Utility.InodeCache
 import Annex.FileMatcher
 import Annex.ReplaceFile
+import Utility.Tmp
 
 def :: [Command]
 def = [notBareRepo $ command "add" paramPaths seek SectionCommon
@@ -79,37 +80,54 @@ start file = ifAnnexed file addpresent add
 		next $ next $ cleanup file key =<< inAnnex key
 
 {- The file that's being added is locked down before a key is generated,
- - to prevent it from being modified in between. It's hard linked into a
+ - to prevent it from being modified in between. This lock down is not
- - temporary location, and its writable bits are removed. It could still be
+ - perfect at best (and pretty weak at worst). For example, it does not
- - written to by a process that already has it open for writing.
+ - guard against files that are already opened for write by another process.
+ - 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.
  -
  - Lockdown can fail if a file gets deleted, and Nothing will be returned.
  -}
 lockDown :: FilePath -> Annex (Maybe KeySource)
 lockDown file = ifM (crippledFileSystem)
-	( liftIO $ catchMaybeIO $ do
+	( liftIO $ catchMaybeIO nohardlink
+	, do
+		tmp <- fromRepo gitAnnexTmpDir
+		createAnnexDirectory tmp
+		unlessM (isDirect) $ liftIO $
+			void $ tryIO $ preventWrite file
+		liftIO $ catchMaybeIO $ 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
 			{ keyFilename = file
 			, contentLocation = file
 			, inodeCache = cache
 			}
-	, do
+	withhardlink tmpfile = do
-		tmp <- fromRepo gitAnnexTmpDir
+		createLink file tmpfile
-		createAnnexDirectory tmp
+		cache <- genInodeCache tmpfile
-		liftIO $ catchMaybeIO $ do
+		return $ KeySource
-			preventWrite file
+			{ keyFilename = file
-			(tmpfile, h) <- openTempFile tmp (takeFileName file)
+			, contentLocation = tmpfile
-			hClose h
+			, inodeCache = cache
-			nukeFile tmpfile
+			}
-			createLink file tmpfile
-			cache <- genInodeCache tmpfile
-			return $ KeySource
-				{ keyFilename = file
-				, contentLocation = tmpfile
-				, inodeCache = cache
-				}
-	)
 
 {- Ingests a locked down file into the annex.
  -
@@ -151,8 +169,6 @@ ingest (Just source) = do
 finishIngestDirect :: Key -> KeySource -> Annex ()
 finishIngestDirect key source = do
 	void $ addAssociatedFile key $ keyFilename source
-	unlessM crippledFileSystem $
-		liftIO $ allowWrite $ keyFilename source
 	when (contentLocation source /= keyFilename source) $
 		liftIO $ nukeFile $ contentLocation source
 
@@ -174,7 +190,7 @@ undo file key e = do
 		liftIO $ nukeFile file
 		catchAnnex (fromAnnex key file) tryharder
 		logStatus key InfoMissing
-	throw e
+	throwAnnex e
   where
 	-- fromAnnex could fail if the file ownership is weird
 	tryharder :: IOException -> Annex ()

Command/AddUnused.hs

@@ -8,10 +8,10 @@
 module Command.AddUnused where
 
 import Common.Annex
-import Logs.Unused
 import Logs.Location
 import Command
 import qualified Command.Add
+import Command.Unused (withUnusedMaps, UnusedMaps(..), startUnused)
 import Types.Key
 
 def :: [Command]

Command/AddUrl.hs

@@ -1,6 +1,6 @@
 {- git-annex command
  -
- - Copyright 2011 Joey Hess <joey@kitenet.net>
+ - Copyright 2011-2013 Joey Hess <joey@kitenet.net>
  -
  - Licensed under the GNU GPL version 3 or higher.
  -}
@@ -54,17 +54,15 @@ start relaxed optfile pathdepth s = go $ fromMaybe bad $ parseURI s
 	bad = fromMaybe (error $ "bad url " ++ s) $
 		parseURI $ escapeURIString isUnescapedInURI s
 	go url = do
-		let file = fromMaybe (url2file url pathdepth) optfile
+		pathmax <- liftIO $ fileNameLengthLimit "."
+		let file = fromMaybe (url2file url pathdepth pathmax) optfile
 		showStart "addurl" file
 		next $ perform relaxed s file
 
 perform :: Bool -> String -> FilePath -> CommandPerform
 perform relaxed url file = ifAnnexed file addurl geturl
   where
-	geturl = do
+	geturl = next $ addUrlFile relaxed url file
-		liftIO $ createDirectoryIfMissing True (parentDir file)
-		ifM (Annex.getState Annex.fast <||> pure relaxed)
-			( nodownload relaxed url file , download url file )
 	addurl (key, _backend)
 		| relaxed = do
 			setUrlPresent key url
@@ -76,26 +74,39 @@ perform relaxed url file = ifAnnexed file addurl geturl
 					setUrlPresent key url
 					next $ return True
 				, do
-					warning $ "failed to verify url: " ++ url
+					warning $ "failed to verify url exists: " ++ url
 					stop
 				)
 
-download :: String -> FilePath -> CommandPerform
+addUrlFile :: Bool -> String -> FilePath -> Annex Bool
+addUrlFile relaxed url file = do
+	liftIO $ createDirectoryIfMissing True (parentDir file)
+	ifM (Annex.getState Annex.fast <||> pure relaxed)
+		( nodownload relaxed url file
+		, do
+			showAction $ "downloading " ++ url ++ " "
+			download url file
+		)
+
+download :: String -> FilePath -> Annex Bool
 download url file = do
-	showAction $ "downloading " ++ url ++ " "
 	dummykey <- genkey
 	tmp <- fromRepo $ gitAnnexTmpLocation dummykey
-	stopUnless (runtransfer dummykey tmp) $ do
+	showOutput
-		backend <- chooseBackend file
+	ifM (runtransfer dummykey tmp)
-		let source = KeySource
+		( do
-			{ keyFilename = file
+			backend <- chooseBackend file
-			, contentLocation = tmp
+			let source = KeySource
-			, inodeCache = Nothing
+				{ keyFilename = file
-			}
+				, contentLocation = tmp
-		k <- genKey source backend
+				, inodeCache = Nothing
-		case k of
+				}
-			Nothing -> stop
+			k <- genKey source backend
-			Just (key, _) -> next $ cleanup url file key (Just tmp)
+			case k of
+				Nothing -> return False
+				Just (key, _) -> cleanup url file key (Just tmp)
+		, return False
+		)
   where
 	{- Generate a dummy key to use for this download, before we can
 	 - examine the file and find its real key. This allows resuming
@@ -112,14 +123,14 @@ download url file = do
 				liftIO $ snd <$> Url.exists url headers
 			, return Nothing
 			)
-		return $ Backend.URL.fromUrl url size
+		Backend.URL.fromUrl url size
   	runtransfer dummykey tmp = 
 		Transfer.download webUUID dummykey (Just file) Transfer.forwardRetry $ const $ do
 			liftIO $ createDirectoryIfMissing True (parentDir tmp)
 			downloadUrl [url] tmp
 		
 
-cleanup :: String -> FilePath -> Key -> Maybe FilePath -> CommandCleanup
+cleanup :: String -> FilePath -> Key -> Maybe FilePath -> Annex Bool
 cleanup url file key mtmp = do
 	when (isJust mtmp) $
 		logStatus key InfoPresent
@@ -133,7 +144,7 @@ cleanup url file key mtmp = do
 	maybe noop (moveAnnex key) mtmp
 	return True
 
-nodownload :: Bool -> String -> FilePath -> CommandPerform
+nodownload :: Bool -> String -> FilePath -> Annex Bool
 nodownload relaxed url file = do
 	headers <- getHttpHeaders
 	(exists, size) <- if relaxed
@@ -141,23 +152,23 @@ nodownload relaxed url file = do
 		else liftIO $ Url.exists url headers
 	if exists
 		then do
-			let key = Backend.URL.fromUrl url size
+			key <- Backend.URL.fromUrl url size
-			next $ cleanup url file key Nothing
+			cleanup url file key Nothing
 		else do
 			warning $ "unable to access url: " ++ url
-			stop
+			return False
 
-url2file :: URI -> Maybe Int -> FilePath
+url2file :: URI -> Maybe Int -> Int -> FilePath
-url2file url pathdepth = case pathdepth of
+url2file url pathdepth pathmax = case pathdepth of
-	Nothing -> filesize $ escape fullurl
+	Nothing -> truncateFilePath pathmax $ escape fullurl
 	Just depth
+		| depth >= length urlbits -> frombits id
 		| depth > 0 -> frombits $ drop depth
 		| depth < 0 -> frombits $ reverse . take (negate depth) . reverse
 		| otherwise -> error "bad --pathdepth"
   where
 	fullurl = uriRegName auth ++ uriPath url ++ uriQuery url
 	frombits a = intercalate "/" $ a urlbits
-	urlbits = map (filesize . escape) $ filter (not . null) $ split "/" fullurl
+	urlbits = map (truncateFilePath pathmax . escape) $ filter (not . null) $ split "/" fullurl
 	auth = fromMaybe (error $ "bad url " ++ show url) $ uriAuthority url
-	filesize = take 255
 	escape = replace "/" "_" . replace "?" "_"

Command/Assistant.hs

@@ -13,6 +13,7 @@ import qualified Option
 import qualified Command.Watch
 import Init
 import Config.Files
+import qualified Build.SysConfig
 
 import System.Environment
 
@@ -55,13 +56,16 @@ autoStart = do
 		f <- autoStartFile
 		error $ "Nothing listed in " ++ f
 	program <- readProgramFile
+	haveionice <- pure Build.SysConfig.ionice <&&> inPath "ionice"
 	forM_ dirs $ \d -> do
 		putStrLn $ "git-annex autostart in " ++ d
-		ifM (catchBoolIO $ go program d)
+		ifM (catchBoolIO $ go haveionice program d)
 			( putStrLn "ok"
 			, putStrLn "failed"
 			)
   where
-	go program dir = do
+	go haveionice program dir = do
 		setCurrentDirectory dir
-		boolSystem program [Param "assistant"]
+		if haveionice
+			then boolSystem "ionice" [Param "-c3", Param program, Param "assistant"]
+			else boolSystem program [Param "assistant"]

Command/Content.hs

@@ -0,0 +1,48 @@
+{- git-annex command
+ -
+ - Copyright 2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.Content where
+
+import Common.Annex
+import Command
+import qualified Remote
+import Logs.PreferredContent
+
+import qualified Data.Map as M
+
+def :: [Command]
+def = [command "content" (paramPair paramRemote (paramOptional paramExpression)) seek
+	SectionSetup "get or set preferred content expression"]
+
+seek :: [CommandSeek]
+seek = [withWords start]
+
+start :: [String] -> CommandStart
+start = parse
+  where
+  	parse (name:[]) = go name performGet
+	parse (name:expr:[]) = go name $ \uuid -> do
+		showStart "content" name
+		performSet expr uuid
+	parse _ = error "Specify a repository."
+
+	go name a = do
+		u <- Remote.nameToUUID name
+		next $ a u
+
+performGet :: UUID -> CommandPerform
+performGet uuid = do
+	m <- preferredContentMapRaw
+	liftIO $ putStrLn $ fromMaybe "" $ M.lookup uuid m
+	next $ return True
+
+performSet :: String -> UUID -> CommandPerform
+performSet expr uuid = case checkPreferredContentExpression expr of
+	Just e -> error $ "Parse error: " ++ e
+	Nothing -> do
+		preferredContentSet uuid expr
+		next $ return True

Command/Copy.hs

@@ -14,13 +14,16 @@ import qualified Remote
 import Annex.Wanted
 
 def :: [Command]
-def = [withOptions Command.Move.options $ command "copy" paramPaths seek
+def = [withOptions Command.Move.moveOptions $ command "copy" paramPaths seek
 	SectionCommon "copy content of files to/from another repository"]
 
 seek :: [CommandSeek]
-seek = [withField Command.Move.toOption Remote.byNameWithUUID $ \to ->
+seek =
-		withField Command.Move.fromOption Remote.byNameWithUUID $ \from ->
+	[ withField Command.Move.toOption Remote.byNameWithUUID $ \to ->
-			withFilesInGit $ whenAnnexed $ start to from]
+	  withField Command.Move.fromOption Remote.byNameWithUUID $ \from ->
+	  withKeyOptions (Command.Move.startKey to from False) $
+	  withFilesInGit $ whenAnnexed $ start to from
+	]
 
 {- A copy is just a move that does not delete the source file.
  - However, --auto mode avoids unnecessary copies, and avoids getting or
@@ -33,4 +36,3 @@ start to from file (key, backend) = stopUnless shouldCopy $
 	check = case to of
 		Nothing -> wantGet False (Just file)
 		Just r -> wantSend False (Just file) (Remote.uuid r)
-		

Command/Dead.hs

@@ -25,7 +25,7 @@ seek = [withWords start]
 start :: [String] -> CommandStart
 start ws = do
 	let name = unwords ws
-	showStart "dead " name
+	showStart "dead" name
 	u <- Remote.nameToUUID name
 	next $ perform u
 

Command/DropUnused.hs

@@ -7,7 +7,6 @@
 
 module Command.DropUnused where
 
-import Logs.Unused
 import Common.Annex
 import Command
 import qualified Annex
@@ -15,6 +14,7 @@ import qualified Command.Drop
 import qualified Remote
 import qualified Git
 import qualified Option
+import Command.Unused (withUnusedMaps, UnusedMaps(..), startUnused)
 
 def :: [Command]
 def = [withOptions [Command.Drop.fromOption] $
@@ -32,9 +32,8 @@ perform key = maybe droplocal dropremote =<< Remote.byNameWithUUID =<< from
   where
 	dropremote r = do
 		showAction $ "from " ++ Remote.name r
-		ok <- Remote.removeKey r key
+		Command.Drop.performRemote key Nothing r
-		next $ Command.Drop.cleanupRemote key r ok
+	droplocal = Command.Drop.performLocal key Nothing Nothing
-	droplocal = Command.Drop.performLocal key (Just 0) Nothing -- force drop
 	from = Annex.getField $ Option.name Command.Drop.fromOption
 
 performOther :: (Key -> Git.Repo -> FilePath) -> Key -> CommandPerform

Command/Find.hs

@@ -20,7 +20,7 @@ import Types.Key
 import qualified Option
 
 def :: [Command]
-def = [noCommit $ withOptions [formatOption, print0Option] $
+def = [noCommit $ noMessages $ withOptions [formatOption, print0Option] $
 	command "find" paramPaths seek SectionQuery "lists available files"]
 
 formatOption :: Option

Command/Fix.hs

@@ -5,6 +5,8 @@
  - Licensed under the GNU GPL version 3 or higher.
  -}
 
+{-# LANGUAGE CPP #-}
+
 module Command.Fix where
 
 import System.PosixCompat.Files
@@ -12,6 +14,9 @@ import System.PosixCompat.Files
 import Common.Annex
 import Command
 import qualified Annex.Queue
+#ifndef __ANDROID__
+import Utility.Touch
+#endif
 
 def :: [Command]
 def = [notDirect $ noCommit $ command "fix" paramPaths seek
@@ -30,9 +35,18 @@ start file (key, _) = do
 
 perform :: FilePath -> FilePath -> CommandPerform
 perform file link = do
-	liftIO $ createDirectoryIfMissing True (parentDir file)
+	liftIO $ do
-	liftIO $ removeFile file
+#ifndef __ANDROID__
-	liftIO $ createSymbolicLink link file
+		-- preserve mtime of symlink
+		mtime <- catchMaybeIO $ TimeSpec . modificationTime
+			<$> getSymbolicLinkStatus file
+#endif
+		createDirectoryIfMissing True (parentDir file)
+		removeFile file
+		createSymbolicLink link file
+#ifndef __ANDROID__
+		maybe noop (\t -> touch file t False) mtime
+#endif
 	next $ cleanup file
 
 cleanup :: FilePath -> CommandCleanup

Command/Fsck.hs

@@ -1,6 +1,6 @@
 {- git-annex command
  -
- - Copyright 2010-2011 Joey Hess <joey@kitenet.net>
+ - Copyright 2010-2013 Joey Hess <joey@kitenet.net>
  -
  - Licensed under the GNU GPL version 3 or higher.
  -}
@@ -20,6 +20,7 @@ import qualified Types.Key
 import qualified Backend
 import Annex.Content
 import Annex.Content.Direct
+import Annex.Direct
 import Annex.Perms
 import Annex.Link
 import Logs.Location
@@ -31,8 +32,10 @@ import Config
 import qualified Option
 import Types.Key
 import Utility.HumanTime
+import Git.FilePath
+import GitAnnex.Options
 
-#ifndef __WINDOWS__
+#ifndef mingw32_HOST_OS
 import System.Posix.Process (getProcessID)
 #else
 import System.Random (getStdRandom, random)
@@ -43,7 +46,7 @@ import System.Posix.Types (EpochTime)
 import System.Locale
 
 def :: [Command]
-def = [withOptions options $ command "fsck" paramPaths seek
+def = [withOptions fsckOptions $ command "fsck" paramPaths seek
 	SectionMaintenance "check for problems"]
 
 fromOption :: Option
@@ -59,19 +62,20 @@ incrementalScheduleOption :: Option
 incrementalScheduleOption = Option.field [] "incremental-schedule" paramTime
 	"schedule incremental fscking"
 
-options :: [Option]
+fsckOptions :: [Option]
-options = 
+fsckOptions = 
 	[ fromOption
 	, startIncrementalOption
 	, moreIncrementalOption
 	, incrementalScheduleOption
-	]
+	] ++ keyOptions
 
 seek :: [CommandSeek]
 seek =
 	[ withField fromOption Remote.byNameWithUUID $ \from ->
-	  withIncremental $ \i -> withFilesInGit $ whenAnnexed $ start from i
+	  withIncremental $ \i ->
-	, withIncremental $ \i -> withBarePresentKeys $ startBare i
+	  withKeyOptions (startKey i) $
+	  withFilesInGit $ whenAnnexed $ start from i
 	]
 
 withIncremental :: (Incremental -> CommandSeek) -> CommandSeek
@@ -119,6 +123,7 @@ perform key file backend numcopies = check
 	[ fixLink key file
 	, verifyLocationLog key file
 	, verifyDirectMapping key file
+	, verifyDirectMode key file
 	, checkKeySize key
 	, checkBackend backend key (Just file)
 	, checkKeyNumCopies key file numcopies
@@ -146,7 +151,7 @@ performRemote key file backend numcopies remote =
 		, checkKeyNumCopies key file numcopies
 		]
 	withtmp a = do
-#ifndef __WINDOWS__
+#ifndef mingw32_HOST_OS
 		v <- liftIO getProcessID
 #else
 		v <- liftIO (getStdRandom random :: IO Int)
@@ -167,26 +172,15 @@ performRemote key file backend numcopies remote =
 			)
 	dummymeter _ = noop
 
-{- To fsck a bare repository, fsck each key in the location log. -}
+startKey :: Incremental -> Key -> CommandStart
-withBarePresentKeys :: (Key -> CommandStart) -> CommandSeek
+startKey inc key = case Backend.maybeLookupBackendName (Types.Key.keyBackendName key) of
-withBarePresentKeys a params = isBareRepo >>= go
-  where
-	go False = return []
-	go True = do
-		unless (null params) $
-			error "fsck should be run without parameters in a bare repository"
-		map a <$> loggedKeys
-
-startBare :: Incremental -> Key -> CommandStart
-startBare inc key = case Backend.maybeLookupBackendName (Types.Key.keyBackendName key) of
 	Nothing -> stop
-	Just backend -> runFsck inc (key2file key) key $ performBare key backend
+	Just backend -> runFsck inc (key2file key) key $ performAll key backend
 
-{- Note that numcopies cannot be checked in a bare repository, because
+{- Note that numcopies cannot be checked in --all mode, since we do not
- - getting the numcopies value requires a working copy with .gitattributes
+ - have associated filenames to look up in the .gitattributes file. -}
- - files. -}
+performAll :: Key -> Backend -> Annex Bool
-performBare :: Key -> Backend -> Annex Bool
+performAll key backend = check
-performBare key backend = check
 	[ verifyLocationLog key (key2file key)
 	, checkKeySize key
 	, checkBackend backend key Nothing
@@ -206,24 +200,13 @@ fixLink key file = do
 	maybe noop (go want) have
 	return True
   where
-	go want have = when (want /= have) $ do
+	go want have
-		{- Version 3.20120227 had a bug that could cause content
+		| want /= fromInternalGitPath have = do
-		 - to be stored in the wrong hash directory. Clean up
+			showNote "fixing link"
-		 - after the bug by moving the content.
+			liftIO $ createDirectoryIfMissing True (parentDir file)
-		 -}
+			liftIO $ removeFile file
-		whenM (liftIO $ doesFileExist file) $
+			addAnnexLink want file
-			unlessM (inAnnex key) $ do
+		| otherwise = noop
-				showNote "fixing content location"
-				dir <- liftIO $ parentDir <$> absPath file
-				let content = absPathFrom dir have
-				unlessM crippledFileSystem $
-					liftIO $ allowWrite (parentDir content)
-				moveAnnex key content
-
-		showNote "fixing link"
-		liftIO $ createDirectoryIfMissing True (parentDir file)
-		liftIO $ removeFile file
-		addAnnexLink want file
 
 {- Checks that the location log reflects the current status of the key,
  - in this repository only. -}
@@ -285,6 +268,20 @@ verifyDirectMapping key file = do
 				void $ removeAssociatedFile key f
 	return True
 
+{- Ensures that files whose content is available are in direct mode. -}
+verifyDirectMode :: Key -> FilePath -> Annex Bool
+verifyDirectMode key file = do
+	whenM (isDirect <&&> islink) $ do
+		v <- toDirectGen key file
+		case v of
+			Nothing -> noop
+			Just a -> do
+				showNote "fixing direct mode"
+				a
+	return True
+  where
+	islink = liftIO $ isSymbolicLink <$> getSymbolicLinkStatus file
+
 {- The size of the data for a key is checked against the size encoded in
  - the key's metadata, if available.
  -
@@ -461,7 +458,7 @@ recordFsckTime key = do
 	parent <- parentDir <$> calcRepo (gitAnnexLocation key)
 	liftIO $ void $ tryIO $ do
 		touchFile parent
-#ifndef __WINDOWS__
+#ifndef mingw32_HOST_OS
 		setSticky parent
 #endif
 

Command/FuzzTest.hs

@@ -0,0 +1,288 @@
+{- git-annex fuzz generator
+ -
+ - Copyright 2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.FuzzTest where
+
+import Common.Annex
+import qualified Annex
+import Command
+import qualified Git.Config
+import Config
+import Utility.ThreadScheduler
+import Annex.Exception
+import Utility.DiskFree
+
+import Data.Time.Clock
+import System.Random (getStdRandom, random, randomR)
+import Test.QuickCheck
+import Control.Concurrent
+
+def :: [Command]
+def = [ notBareRepo $ command "fuzztest" paramNothing seek SectionPlumbing
+	"generates fuzz test files"]
+
+seek :: [CommandSeek]
+seek = [withNothing start]
+
+start :: CommandStart
+start = do
+	guardTest
+	logf <- fromRepo gitAnnexFuzzTestLogFile
+	showStart "fuzztest" logf
+	logh <-liftIO $ openFile logf WriteMode
+	void $ forever $ fuzz logh
+	stop
+
+guardTest :: Annex ()
+guardTest = unlessM (fromMaybe False . Git.Config.isTrue <$> getConfig key "") $
+	error $ unlines
+		[ "Running fuzz tests *writes* to and *deletes* files in"
+		, "this repository, and pushes those changes to other"
+		, "repositories! This is a developer tool, not something"
+		, "to play with."
+		, ""
+		, "Refusing to run fuzz tests, since " ++ keyname ++ " is not set!"
+		]
+  where
+  	key = annexConfig "eat-my-repository"
+	(ConfigKey keyname) = key
+
+
+fuzz :: Handle -> Annex ()
+fuzz logh = do
+	action <- genFuzzAction
+	record logh $ flip Started action
+	result <- tryAnnex $ runFuzzAction action
+	record logh $ flip Finished $
+		either (const False) (const True) result
+
+record :: Handle -> (UTCTime -> TimeStampedFuzzAction) -> Annex ()
+record h tmpl = liftIO $ do
+	now <- getCurrentTime
+	let s = show $ tmpl now
+	print s
+	hPrint h s
+	hFlush h
+
+{- Delay for either a fraction of a second, or a few seconds, or up
+ - to 1 minute.
+ -
+ - The MinutesDelay is used as an opportunity to do housekeeping tasks.
+ -}
+randomDelay :: Delay -> Annex ()
+randomDelay TinyDelay = liftIO $
+	threadDelay =<< getStdRandom (randomR (10000, 1000000))
+randomDelay SecondsDelay = liftIO $ 
+	threadDelaySeconds =<< Seconds <$> getStdRandom (randomR (1, 10))
+randomDelay MinutesDelay = do
+	liftIO $ threadDelaySeconds =<< Seconds <$> getStdRandom (randomR (1, 60))
+	reserve <- annexDiskReserve <$> Annex.getGitConfig
+	free <- liftIO $ getDiskFree "."
+	case free of
+		Just have | have < reserve -> do
+			warning "Low disk space; fuzz test paused."
+			liftIO $ threadDelaySeconds (Seconds 60)
+			randomDelay MinutesDelay
+		_  -> noop
+
+data Delay
+	= TinyDelay
+	| SecondsDelay
+	| MinutesDelay
+	deriving (Read, Show, Eq)
+
+instance Arbitrary Delay where
+	arbitrary = elements [TinyDelay, SecondsDelay, MinutesDelay]
+
+data FuzzFile = FuzzFile FilePath
+	deriving (Read, Show, Eq)
+
+data FuzzDir = FuzzDir FilePath
+	deriving (Read, Show, Eq)
+
+instance Arbitrary FuzzFile where
+	arbitrary = FuzzFile <$> arbitrary
+
+instance Arbitrary FuzzDir where
+	arbitrary = FuzzDir <$> arbitrary
+
+class ToFilePath a where
+	toFilePath :: a -> FilePath
+
+instance ToFilePath FuzzFile where
+	toFilePath (FuzzFile f) = f
+
+instance ToFilePath FuzzDir where
+	toFilePath (FuzzDir d) = d
+
+isFuzzFile :: FilePath -> Bool
+isFuzzFile f = "fuzzfile_" `isPrefixOf` takeFileName f
+
+isFuzzDir :: FilePath -> Bool
+isFuzzDir d = "fuzzdir_" `isPrefixOf` d
+
+mkFuzzFile :: FilePath -> [FuzzDir] -> FuzzFile
+mkFuzzFile file dirs = FuzzFile $ joinPath (map toFilePath dirs) </> ("fuzzfile_" ++ file)
+
+mkFuzzDir :: Int -> FuzzDir
+mkFuzzDir n = FuzzDir $ "fuzzdir_" ++ show n
+
+{- File is placed inside a directory hierarchy up to 4 subdirectories deep. -}
+genFuzzFile :: IO FuzzFile
+genFuzzFile = do
+	n <- getStdRandom $ randomR (0, 4)
+	dirs <- replicateM n genFuzzDir
+	file <- show <$> (getStdRandom random :: IO Int)
+	return $ mkFuzzFile file dirs
+
+{- Only 16 distinct subdirectories are used. When nested 4 deep, this
+ - yields 69904 total directories max, which is below the default Linux
+ - inotify limit of 81920. The goal is not to run the assistant out of
+ - inotify descriptors. -}
+genFuzzDir :: IO FuzzDir
+genFuzzDir = mkFuzzDir <$> (getStdRandom (randomR (1,16)) :: IO Int)
+
+localFile :: FilePath -> Bool
+localFile f
+	| isAbsolute f = False
+	| ".." `isInfixOf` f = False
+	| ".git" `isPrefixOf` f = False
+	| otherwise = True
+
+data TimeStampedFuzzAction 
+	= Started UTCTime FuzzAction
+	| Finished UTCTime Bool
+	deriving (Read, Show)
+
+data FuzzAction
+	= FuzzAdd FuzzFile
+	| FuzzDelete FuzzFile
+	| FuzzMove FuzzFile FuzzFile
+	| FuzzModify FuzzFile
+	| FuzzDeleteDir FuzzDir
+	| FuzzMoveDir FuzzDir FuzzDir
+	| FuzzPause Delay
+	deriving (Read, Show, Eq)
+
+instance Arbitrary FuzzAction where
+	arbitrary = frequency
+		[ (50, FuzzAdd <$> arbitrary)
+		, (50, FuzzDelete <$> arbitrary)
+		, (10, FuzzMove <$> arbitrary <*> arbitrary)
+		, (10, FuzzModify <$> arbitrary)
+		, (10, FuzzDeleteDir <$> arbitrary)
+		, (10, FuzzMoveDir <$> arbitrary <*> arbitrary)
+		, (10, FuzzPause <$> arbitrary)
+		]
+
+runFuzzAction :: FuzzAction -> Annex ()
+runFuzzAction (FuzzAdd (FuzzFile f)) = liftIO $ do
+	createDirectoryIfMissing True $ parentDir f
+	n <- getStdRandom random :: IO Int
+	writeFile f $ show n ++ "\n"
+runFuzzAction (FuzzDelete (FuzzFile f)) = liftIO $ nukeFile f
+runFuzzAction (FuzzMove (FuzzFile src) (FuzzFile dest)) = liftIO $
+	rename src dest
+runFuzzAction (FuzzModify (FuzzFile f)) = whenM isDirect $ liftIO $ do
+	n <- getStdRandom random :: IO Int
+	appendFile f $ show n ++ "\n"
+runFuzzAction (FuzzDeleteDir (FuzzDir d)) = liftIO $
+	removeDirectoryRecursive d
+runFuzzAction (FuzzMoveDir (FuzzDir src) (FuzzDir dest)) = liftIO $
+	rename src dest
+runFuzzAction (FuzzPause d) = randomDelay d
+
+genFuzzAction :: Annex FuzzAction
+genFuzzAction = do
+	tmpl <- liftIO $ Prelude.head <$> sample' (arbitrary :: Gen FuzzAction)
+	-- Fix up template action to make sense in the current repo tree.
+	case tmpl of
+		FuzzAdd _ -> do
+			f <- liftIO newFile
+			maybe genFuzzAction (return . FuzzAdd) f
+		FuzzDelete _ -> do
+			f <- liftIO $ existingFile 0 ""
+			maybe genFuzzAction (return . FuzzDelete) f
+		FuzzMove _ _ -> do
+			src <- liftIO $ existingFile 0 ""
+			dest <- liftIO newFile
+			case (src, dest) of
+				(Just s, Just d) -> return $ FuzzMove s d
+				_ -> genFuzzAction
+		FuzzMoveDir _ _ -> do
+			md <- liftIO existingDir
+			case md of
+				Nothing -> genFuzzAction
+				Just d -> do
+					newd <- liftIO $ newDir (parentDir $ toFilePath d)
+					maybe genFuzzAction (return . FuzzMoveDir d) newd
+		FuzzDeleteDir _ -> do
+			d <- liftIO existingDir
+			maybe genFuzzAction (return . FuzzDeleteDir) d
+		FuzzModify _ -> do
+			f <- liftIO $ existingFile 0 ""
+			maybe genFuzzAction (return . FuzzModify) f
+		FuzzPause _ -> return tmpl
+
+existingFile :: Int -> FilePath -> IO (Maybe FuzzFile)
+existingFile 0 _ = return Nothing
+existingFile n top = do
+	dir <- existingDirIncludingTop
+	contents <- catchDefaultIO [] (getDirectoryContents dir)
+	let files = filter isFuzzFile contents
+	if null files
+		then do
+			let dirs = filter isFuzzDir contents
+			if null dirs
+				then return Nothing
+				else do
+					i <- getStdRandom $ randomR (0, length dirs - 1)
+					existingFile (n - 1) (top </> dirs !! i)
+		else do
+			i <- getStdRandom $ randomR (0, length files - 1)
+			return $ Just $ FuzzFile $ top </> dir </> files !! i
+
+existingDirIncludingTop :: IO FilePath
+existingDirIncludingTop = do
+	dirs <- filter isFuzzDir <$> getDirectoryContents "."
+	if null dirs
+		then return "."
+		else do
+			n <- getStdRandom $ randomR (0, length dirs)
+			return $ ("." : dirs) !! n
+
+existingDir :: IO (Maybe FuzzDir)
+existingDir = do
+	d <- existingDirIncludingTop
+	return $ if isFuzzDir d
+		then Just $ FuzzDir d
+		else Nothing
+
+newFile :: IO (Maybe FuzzFile)
+newFile = go (100 :: Int)
+  where
+  	go 0 = return Nothing
+	go n = do
+		f <- genFuzzFile
+		ifM (doesnotexist (toFilePath f))
+			( return $ Just f
+			, go (n - 1)
+			)
+
+newDir :: FilePath -> IO (Maybe FuzzDir)
+newDir parent = go (100 :: Int)
+  where
+  	go 0 = return Nothing
+	go n = do
+		(FuzzDir d) <- genFuzzDir
+		ifM (doesnotexist (parent </> d))
+			( return $ Just $ FuzzDir d
+			, go (n - 1)
+			)
+
+doesnotexist :: FilePath -> IO Bool
+doesnotexist f = isNothing <$> catchMaybeIO (getSymbolicLinkStatus f)

Command/Get.hs

@@ -1,6 +1,6 @@
 {- git-annex command
  -
- - Copyright 2010 Joey Hess <joey@kitenet.net>
+ - Copyright 2010, 2013 Joey Hess <joey@kitenet.net>
  -
  - Licensed under the GNU GPL version 3 or higher.
  -}
@@ -14,37 +14,52 @@ import Annex.Content
 import qualified Command.Move
 import Logs.Transfer
 import Annex.Wanted
+import GitAnnex.Options
+import Types.Key
 
 def :: [Command]
-def = [withOptions [Command.Move.fromOption] $ command "get" paramPaths seek
+def = [withOptions getOptions $ command "get" paramPaths seek
 	SectionCommon "make content of annexed files available"]
 
+getOptions :: [Option]
+getOptions = [Command.Move.fromOption] ++ keyOptions
+
 seek :: [CommandSeek]
-seek = [withField Command.Move.fromOption Remote.byNameWithUUID $ \from ->
+seek = 
-	withFilesInGit $ whenAnnexed $ start from]
+	[ withField Command.Move.fromOption Remote.byNameWithUUID $ \from ->
+	  withKeyOptions (startKeys from) $
+	  withFilesInGit $ whenAnnexed $ start from
+	]
 
 start :: Maybe Remote -> FilePath -> (Key, Backend) -> CommandStart
-start from file (key, _) = stopUnless (not <$> inAnnex key) $
+start from file (key, _) = start' expensivecheck from key (Just file)
-	stopUnless (checkAuto (numCopiesCheck file key (<) <||> wantGet False (Just file))) $ do
-		case from of
-			Nothing -> go $ perform key file
-			Just src ->
-				-- get --from = copy --from
-				stopUnless (Command.Move.fromOk src key) $
-					go $ Command.Move.fromPerform src False key file
   where
-	go a = do
+	expensivecheck = checkAuto (numCopiesCheck file key (<) <||> wantGet False (Just file))
-		showStart "get" file
+
+startKeys :: Maybe Remote -> Key -> CommandStart
+startKeys from key = start' (return True) from key Nothing
+
+start' :: Annex Bool -> Maybe Remote -> Key -> AssociatedFile -> CommandStart
+start' expensivecheck from key afile = stopUnless (not <$> inAnnex key) $
+	stopUnless expensivecheck $
+		case from of
+			Nothing -> go $ perform key afile
+			Just src ->
+				stopUnless (Command.Move.fromOk src key) $
+					go $ Command.Move.fromPerform src False key afile
+  where
+  	go a = do
+		showStart "get" (fromMaybe (key2file key) afile)
 		next a
 
-perform :: Key -> FilePath -> CommandPerform
+perform :: Key -> AssociatedFile -> CommandPerform
-perform key file = stopUnless (getViaTmp key $ getKeyFile key file) $
+perform key afile = stopUnless (getViaTmp key $ getKeyFile key afile) $
 	next $ return True -- no cleanup needed
 
 {- Try to find a copy of the file in one of the remotes,
  - and copy it to here. -}
-getKeyFile :: Key -> FilePath -> FilePath -> Annex Bool
+getKeyFile :: Key -> AssociatedFile -> FilePath -> Annex Bool
-getKeyFile key file dest = dispatch =<< Remote.keyPossibilities key
+getKeyFile key afile dest = dispatch =<< Remote.keyPossibilities key
   where
 	dispatch [] = do
 		showNote "not available"
@@ -69,7 +84,7 @@ getKeyFile key file dest = dispatch =<< Remote.keyPossibilities key
 			either (const False) id <$> Remote.hasKey r key
 		| otherwise = return True
 	docopy r continue = do
-		ok <- download (Remote.uuid r) key (Just file) noRetry $ \p -> do
+		ok <- download (Remote.uuid r) key afile noRetry $ \p -> do
 			showAction $ "from " ++ Remote.name r
-			Remote.retrieveKeyFile r key (Just file) dest p
+			Remote.retrieveKeyFile r key afile dest p
 		if ok then return ok else continue

Command/Group.hs

@@ -17,7 +17,7 @@ import qualified Data.Set as S
 
 def :: [Command]
 def = [command "group" (paramPair paramRemote paramDesc) seek
-	SectionCommon "add a repository to a group"]
+	SectionSetup "add a repository to a group"]
 
 seek :: [CommandSeek]
 seek = [withWords start]

Command/Import.hs

@@ -15,7 +15,7 @@ import qualified Annex
 import qualified Command.Add
 
 def :: [Command]
-def = [notDirect $ notBareRepo $ command "import" paramPaths seek
+def = [notBareRepo $ command "import" paramPaths seek
 	SectionCommon "move and add files from outside git working copy"]
 
 seek :: [CommandSeek]

Command/ImportFeed.hs

@@ -0,0 +1,173 @@
+{- git-annex command
+ -
+ - Copyright 2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.ImportFeed where
+
+import Text.Feed.Import
+import Text.Feed.Query
+import Text.Feed.Types
+import qualified Data.Set as S
+import qualified Data.Map as M
+import Data.Char
+
+import Common.Annex
+import qualified Annex
+import Command
+import qualified Utility.Url as Url
+import Logs.Web
+import qualified Option
+import qualified Utility.Format
+import Utility.Tmp
+import Command.AddUrl (addUrlFile, relaxedOption)
+
+def :: [Command]
+def = [notBareRepo $ withOptions [templateOption, relaxedOption] $
+	command "importfeed" (paramRepeating paramUrl) seek
+		SectionCommon "import files from podcast feeds"]
+
+templateOption :: Option
+templateOption = Option.field [] "template" paramFormat "template for filenames"
+
+seek :: [CommandSeek]
+seek = [withField templateOption return $ \tmpl ->
+	withFlag relaxedOption $ \relaxed ->
+	withValue (getCache tmpl) $ \cache ->
+	withStrings $ start relaxed cache]
+
+start :: Bool -> Cache -> URLString -> CommandStart
+start relaxed cache url = do
+	showStart "importfeed" url
+	next $ perform relaxed cache url
+
+perform :: Bool -> Cache -> URLString -> CommandPerform
+perform relaxed cache url = do
+	v <- findEnclosures url
+	case v of
+		Just l | not (null l) -> do
+			mapM_ (downloadEnclosure relaxed cache) l
+			next $ return True
+		_ -> stop
+
+data ToDownload = ToDownload
+	{ feed :: Feed
+	, item :: Item
+	, location :: URLString
+	}
+
+mkToDownload :: Feed -> Item -> Maybe ToDownload
+mkToDownload f i = case getItemEnclosure i of
+	Nothing -> Nothing
+	Just (enclosureurl, _, _) -> Just $ ToDownload f i enclosureurl
+
+data Cache = Cache
+	{ knownurls :: S.Set URLString
+	, template :: Utility.Format.Format
+	}
+
+getCache :: Maybe String -> Annex Cache
+getCache opttemplate = ifM (Annex.getState Annex.force)
+	( ret S.empty
+	, do
+		showSideAction "checking known urls"
+		ret =<< S.fromList <$> knownUrls
+	)
+  where
+	tmpl = Utility.Format.gen $ fromMaybe defaultTemplate opttemplate
+	ret s = return $ Cache s tmpl
+
+findEnclosures :: URLString -> Annex (Maybe [ToDownload])
+findEnclosures url = go =<< downloadFeed url
+  where
+	go Nothing = do
+		warning $ "failed to parse feed " ++ url
+		return Nothing
+	go (Just f) = return $ Just $
+		mapMaybe (mkToDownload f) (feedItems f)
+
+{- Feeds change, so a feed download cannot be resumed. -}
+downloadFeed :: URLString -> Annex (Maybe Feed)
+downloadFeed url = do
+	showOutput
+	liftIO $ withTmpFile "feed" $ \f h -> do
+		fileEncoding h
+		ifM (Url.download url [] [] f)
+			( parseFeedString <$> hGetContentsStrict h
+			, return Nothing
+			)
+
+{- Avoids downloading any urls that are already known to be associated
+ - with a file in the annex, unless forced. -}
+downloadEnclosure :: Bool -> Cache -> ToDownload -> Annex ()
+downloadEnclosure relaxed cache enclosure
+	| S.member url (knownurls cache) =
+		whenM forced go
+	| otherwise = go
+  where
+  	forced = Annex.getState Annex.force
+  	url = location enclosure
+	go = do
+		dest <- makeunique (1 :: Integer) $ feedFile (template cache) enclosure
+		case dest of
+			Nothing -> noop
+			Just f -> do
+				showStart "addurl" f
+				ifM (addUrlFile relaxed url f)
+					( showEndOk
+					, showEndFail
+					)
+	{- Find a unique filename to save the url to.
+	 - If the file exists, prefixes it with a number.
+	 - When forced, the file may already exist and have the same
+	 - url, in which case Nothing is returned as it does not need
+	 - to be re-downloaded. -}
+	makeunique n file = ifM alreadyexists
+		( ifM forced
+			( ifAnnexed f checksameurl tryanother
+			, tryanother
+			)
+		, return $ Just f
+		)
+	  where
+	  	f = if n < 2
+			then file
+			else
+				let (d, base) = splitFileName file
+				in d </> show n ++ "_" ++ base
+		tryanother = makeunique (n + 1) file
+		alreadyexists = liftIO $ isJust <$> catchMaybeIO (getSymbolicLinkStatus f)
+		checksameurl (k, _) = ifM (elem url <$> getUrls k)
+			( return Nothing
+			, tryanother
+			)
+	
+defaultTemplate :: String
+defaultTemplate = "${feedtitle}/${itemtitle}${extension}"
+
+{- Generates a filename to use for a feed item by filling out the template.
+ - The filename may not be unique. -}
+feedFile :: Utility.Format.Format -> ToDownload -> FilePath
+feedFile tmpl i = Utility.Format.format tmpl $ M.fromList
+	[ field "feedtitle" $ getFeedTitle $ feed i
+	, fieldMaybe "itemtitle" $ getItemTitle $ item i
+	, fieldMaybe "feedauthor" $ getFeedAuthor $ feed i
+	, fieldMaybe "itemauthor" $ getItemAuthor $ item i
+	, fieldMaybe "itemsummary" $ getItemSummary $ item i
+	, fieldMaybe "itemdescription" $ getItemDescription $ item i
+	, fieldMaybe "itemrights" $ getItemRights $ item i
+	, fieldMaybe "itemid" $ snd <$> getItemId (item i)
+	, ("extension", map sanitize $ takeExtension $ location i)
+	]
+  where
+	field k v = 
+		let s = map sanitize v in
+		if null s then (k, "none") else (k, s)
+	fieldMaybe k Nothing = (k, "none")
+	fieldMaybe k (Just v) = field k v
+
+	sanitize c
+		| isSpace c || isPunctuation c || c == '/' = '_'
+		| otherwise = c

Command/Indirect.hs

@@ -59,7 +59,7 @@ perform = do
 	setDirect False
 
 	top <- fromRepo Git.repoPath
-	(l, clean) <- inRepo $ Git.LsFiles.stagedDetails [top]
+	(l, clean) <- inRepo $ Git.LsFiles.stagedOthersDetails [top]
 	forM_ l go
 	void $ liftIO clean
 	next cleanup

Command/Merge.hs

@@ -1,6 +1,6 @@
 {- git-annex command
  -
- - Copyright 2011 Joey Hess <joey@kitenet.net>
+ - Copyright 2011, 2013 Joey Hess <joey@kitenet.net>
  -
  - Licensed under the GNU GPL version 3 or higher.
  -}
@@ -10,22 +10,29 @@ module Command.Merge where
 import Common.Annex
 import Command
 import qualified Annex.Branch
+import qualified Git.Branch
+import Command.Sync (mergeLocal)
 
 def :: [Command]
 def = [command "merge" paramNothing seek SectionMaintenance
-	"auto-merge remote changes into git-annex branch"]
+	"automatically merge changes from remotes"]
 
 seek :: [CommandSeek]
-seek = [withNothing start]
+seek =
+	[ withNothing mergeBranch
+	, withNothing mergeSynced
+	]
 
-start :: CommandStart
+mergeBranch :: CommandStart
-start = do
+mergeBranch = do
-	showStart "merge" "."
+	showStart "merge" "git-annex"
-	next perform
+	next $ do
+		Annex.Branch.update
+		-- commit explicitly, in case no remote branches were merged
+		Annex.Branch.commit "update"
+		next $ return True
 
-perform :: CommandPerform
+mergeSynced :: CommandStart
-perform = do
+mergeSynced = do
-	Annex.Branch.update
+	branch <- inRepo Git.Branch.current
-	-- commit explicitly, in case no remote branches were merged
+	maybe stop mergeLocal branch
-	Annex.Branch.commit "update"
-	next $ return True

Command/Move.hs

@@ -1,6 +1,6 @@
 {- git-annex command
  -
- - Copyright 2010-2011 Joey Hess <joey@kitenet.net>
+ - Copyright 2010-2013 Joey Hess <joey@kitenet.net>
  -
  - Licensed under the GNU GPL version 3 or higher.
  -}
@@ -17,9 +17,11 @@ import Annex.UUID
 import qualified Option
 import Logs.Presence
 import Logs.Transfer
+import GitAnnex.Options
+import Types.Key
 
 def :: [Command]
-def = [withOptions options $ command "move" paramPaths seek
+def = [withOptions moveOptions $ command "move" paramPaths seek
 	SectionCommon "move content of files to/from another repository"]
 
 fromOption :: Option
@@ -28,29 +30,40 @@ fromOption = Option.field ['f'] "from" paramRemote "source remote"
 toOption :: Option
 toOption = Option.field ['t'] "to" paramRemote "destination remote"
 
-options :: [Option]
+moveOptions :: [Option]
-options = [fromOption, toOption]
+moveOptions = [fromOption, toOption] ++ keyOptions
 
 seek :: [CommandSeek]
-seek = [withField toOption Remote.byNameWithUUID $ \to ->
+seek = 
-		withField fromOption Remote.byNameWithUUID $ \from ->
+	[ withField toOption Remote.byNameWithUUID $ \to ->
-			withFilesInGit $ whenAnnexed $ start to from True]
+	  withField fromOption Remote.byNameWithUUID $ \from ->
+	  withKeyOptions (startKey to from True) $
+	  withFilesInGit $ whenAnnexed $ start to from True
+	]
 
 start :: Maybe Remote -> Maybe Remote -> Bool -> FilePath -> (Key, Backend) -> CommandStart
-start to from move file (key, _) = do
+start to from move file (key, _) = start' to from move (Just file) key
+
+startKey :: Maybe Remote -> Maybe Remote -> Bool -> Key -> CommandStart
+startKey to from move key = start' to from move Nothing key
+
+start' :: Maybe Remote -> Maybe Remote -> Bool -> AssociatedFile -> Key -> CommandStart
+start' to from move afile key = do
 	noAuto
 	case (from, to) of
 		(Nothing, Nothing) -> error "specify either --from or --to"
-		(Nothing, Just dest) -> toStart dest move file key
+		(Nothing, Just dest) -> toStart dest move afile key
-		(Just src, Nothing) -> fromStart src move file key
+		(Just src, Nothing) -> fromStart src move afile key
 		(_ ,  _) -> error "only one of --from or --to can be specified"
   where
 	noAuto = when move $ whenM (Annex.getState Annex.auto) $ error
 		"--auto is not supported for move"
 
-showMoveAction :: Bool -> FilePath -> Annex ()
+showMoveAction :: Bool -> Key -> AssociatedFile -> Annex ()
-showMoveAction True file = showStart "move" file
+showMoveAction True _ (Just file) = showStart "move" file
-showMoveAction False file = showStart "copy" file
+showMoveAction False _ (Just file) = showStart "copy" file
+showMoveAction True key Nothing = showStart "move" (key2file key)
+showMoveAction False key Nothing = showStart "copy" (key2file key)
 
 {- Moves (or copies) the content of an annexed file to a remote.
  -
@@ -61,17 +74,17 @@ showMoveAction False file = showStart "copy" file
  - A file's content can be moved even if there are insufficient copies to
  - allow it to be dropped.
  -}
-toStart :: Remote -> Bool -> FilePath -> Key -> CommandStart
+toStart :: Remote -> Bool -> AssociatedFile -> Key -> CommandStart
-toStart dest move file key = do
+toStart dest move afile key = do
 	u <- getUUID
 	ishere <- inAnnex key
 	if not ishere || u == Remote.uuid dest
 		then stop -- not here, so nothing to do
 		else do
-			showMoveAction move file
+			showMoveAction move key afile
-			next $ toPerform dest move key file
+			next $ toPerform dest move key afile
-toPerform :: Remote -> Bool -> Key -> FilePath -> CommandPerform
+toPerform :: Remote -> Bool -> Key -> AssociatedFile -> CommandPerform
-toPerform dest move key file = moveLock move key $ do
+toPerform dest move key afile = moveLock move key $ do
 	-- Checking the remote is expensive, so not done in the start step.
 	-- In fast mode, location tracking is assumed to be correct,
 	-- and an explicit check is not done, when copying. When moving,
@@ -87,8 +100,8 @@ toPerform dest move key file = moveLock move key $ do
 			stop
 		Right False -> do
 			showAction $ "to " ++ Remote.name dest
-			ok <- upload (Remote.uuid dest) key (Just file) noRetry $
+			ok <- upload (Remote.uuid dest) key afile noRetry $
-				Remote.storeKey dest key (Just file)
+				Remote.storeKey dest key afile
 			if ok
 				then do
 					Remote.logStatus dest key InfoPresent
@@ -117,14 +130,14 @@ toPerform dest move key file = moveLock move key $ do
  - If the current repository already has the content, it is still removed
  - from the remote.
  -}
-fromStart :: Remote -> Bool -> FilePath -> Key -> CommandStart
+fromStart :: Remote -> Bool -> AssociatedFile -> Key -> CommandStart
-fromStart src move file key
+fromStart src move afile key
 	| move = go
 	| otherwise = stopUnless (not <$> inAnnex key) go
   where
 	go = stopUnless (fromOk src key) $ do
-		showMoveAction move file
+		showMoveAction move key afile
-		next $ fromPerform src move key file
+		next $ fromPerform src move key afile
 
 fromOk :: Remote -> Key -> Annex Bool
 fromOk src key
@@ -137,16 +150,16 @@ fromOk src key
 		remotes <- Remote.keyPossibilities key
 		return $ u /= Remote.uuid src && elem src remotes
 
-fromPerform :: Remote -> Bool -> Key -> FilePath -> CommandPerform
+fromPerform :: Remote -> Bool -> Key -> AssociatedFile -> CommandPerform
-fromPerform src move key file = moveLock move key $
+fromPerform src move key afile = moveLock move key $
 	ifM (inAnnex key)
 		( handle move True
 		, handle move =<< go
 		)
   where
-	go = download (Remote.uuid src) key (Just file) noRetry $ \p -> do
+	go = download (Remote.uuid src) key afile noRetry $ \p -> do
 		showAction $ "from " ++ Remote.name src
-		getViaTmp key $ \t -> Remote.retrieveKeyFile src key (Just file) t p
+		getViaTmp key $ \t -> Remote.retrieveKeyFile src key afile t p
 	handle _ False = stop -- failed
 	handle False True = next $ return True -- copy complete
 	handle True True = do -- finish moving

Command/ReKey.hs

@@ -7,8 +7,6 @@
 
 module Command.ReKey where
 
-import System.PosixCompat.Files
-
 import Common.Annex
 import Command
 import qualified Annex
@@ -17,7 +15,6 @@ import Annex.Content
 import qualified Command.Add
 import Logs.Web
 import Logs.Location
-import Config
 import Utility.CopyFile
 
 def :: [Command]
@@ -49,18 +46,14 @@ perform file oldkey newkey = do
 			return True
 	next $ cleanup file oldkey newkey
 
-{- Make a hard link to the old key content, to avoid wasting disk space. -}
+{- Make a hard link to the old key content (when supported),
+ - to avoid wasting disk space. -}
 linkKey :: Key -> Key -> Annex Bool
 linkKey oldkey newkey = getViaTmpUnchecked newkey $ \tmp -> do
 	src <- calcRepo $ gitAnnexLocation oldkey
-	ifM (liftIO $ doesFileExist tmp)
+	liftIO $ ifM (doesFileExist tmp)
 		( return True
-		, ifM crippledFileSystem
+		, createLinkOrCopy src tmp
-			( liftIO $ copyFileExternal src tmp
-			, do
-				liftIO $ createLink src tmp
-				return True
-			)
 		)
 
 cleanup :: FilePath -> Key -> Key -> CommandCleanup

Command/Status.hs

@@ -35,6 +35,7 @@ import Config
 import Utility.Percentage
 import Logs.Transfer
 import Types.TrustLevel
+import Types.FileMatcher
 import qualified Limit
 
 -- a named computation that produces a statistic
@@ -101,7 +102,6 @@ global_fast_stats =
 	, remote_list Trusted
 	, remote_list SemiTrusted
 	, remote_list UnTrusted
-	, remote_list DeadTrusted
 	, transfer_list
 	, disk_size
 	]
@@ -286,7 +286,7 @@ getLocalStatInfo dir = do
   where
 	initial = (emptyKeyData, emptyKeyData)
 	update matcher key file vs@(presentdata, referenceddata) =
-		ifM (matcher $ Annex.FileInfo file file)
+		ifM (matcher $ FileInfo file file)
 			( (,)
 				<$> ifM (inAnnex key)
 					( return $ addKey key presentdata

Command/Sync.hs

@@ -28,6 +28,7 @@ import qualified Types.Remote
 import qualified Remote.Git
 import Types.Key
 import Config
+import Annex.ReplaceFile
 
 import Data.Hash.MD5
 
@@ -137,7 +138,8 @@ pullRemote remote branch = do
 
 {- The remote probably has both a master and a synced/master branch.
  - Which to merge from? Well, the master has whatever latest changes
- - were committed, while the synced/master may have changes that some
+ - were committed (or pushed changes, if this is a bare remote),
+ - while the synced/master may have changes that some
  - other remote synced to this remote. So, merge them both. -}
 mergeRemote :: Remote -> (Maybe Git.Ref) -> CommandCleanup
 mergeRemote remote b = case b of
@@ -162,15 +164,29 @@ pushRemote remote branch = go =<< needpush
 			showOutput
 			inRepo $ pushBranch remote branch
 
+{- If the remote is a bare git repository, it's best to push the branch
+ - directly to it. On the other hand, if it's not bare, pushing to the
+ - checked out branch will fail, and this is why we use the syncBranch.
+ -
+ - Git offers no way to tell if a remote is bare or not, so both methods
+ - are tried.
+ -
+ - The direct push is likely to spew an ugly error message, so stderr is
+ - elided. Since progress is output to stderr too, the sync push is done
+ - first, and actually sends the data. Then the direct push is tried,
+ - with stderr discarded, to update the branch ref on the remote.
+ -}
 pushBranch :: Remote -> Git.Ref -> Git.Repo -> IO Bool
-pushBranch remote branch g =
+pushBranch remote branch g = tryIO directpush `after` syncpush
-	Git.Command.runBool
+  where
+	syncpush = Git.Command.runBool (pushparams (refspec branch)) g
+	directpush = Git.Command.runQuiet (pushparams (show $ Git.Ref.base branch)) g
+	pushparams b =
 		[ Param "push"
 		, Param $ Remote.name remote
 		, Param $ refspec Annex.Branch.name
-		, Param $ refspec branch
+		, Param b
-		] g
+		]
-  where
 	refspec b = concat 
 		[ show $ Git.Ref.base b
 		,  ":"
@@ -247,8 +263,13 @@ resolveMerge' :: LsFiles.Unmerged -> Annex Bool
 resolveMerge' u
 	| issymlink LsFiles.valUs && issymlink LsFiles.valThem =
 		withKey LsFiles.valUs $ \keyUs ->
-		withKey LsFiles.valThem $ \keyThem -> do
+			withKey LsFiles.valThem $ \keyThem -> do
-			go keyUs keyThem
+				ifM isDirect
+					( maybe noop (\k -> removeDirect k file) keyUs
+					, liftIO $ nukeFile file
+					)
+				Annex.Queue.addCommand "rm" [Params "--quiet -f --"] [file]
+				go keyUs keyThem
 	| otherwise = return False
   where
 	go keyUs keyThem
@@ -256,11 +277,6 @@ resolveMerge' u
 			makelink keyUs
 			return True
 		| otherwise = do
-			ifM isDirect
-				( maybe noop (\k -> removeDirect k file) keyUs
-				, liftIO $ nukeFile file
-				)
-			Annex.Queue.addCommand "rm" [Params "--quiet -f --"] [file]
 			makelink keyUs
 			makelink keyThem
 			return True
@@ -270,8 +286,8 @@ resolveMerge' u
 	makelink (Just key) = do
 		let dest = mergeFile file key
 		l <- inRepo $ gitAnnexLink dest key
-		liftIO $ nukeFile dest
+		replaceFile dest $ makeAnnexLink l
-		addAnnexLink l dest
+		stageSymlink dest =<< hashSymlink l
 		whenM (isDirect) $
 			toDirect key dest
 	makelink _ = noop
@@ -302,7 +318,7 @@ mergeFile file key
 	| otherwise = go $ shortHash $ key2file key
   where
 	varmarker = ".variant-"
-	doubleconflict = varmarker `isSuffixOf` (dropExtension file)
+	doubleconflict = varmarker `isInfixOf` file
 	go v = takeDirectory file
 		</> dropExtension (takeFileName file)
 		++ varmarker ++ v

Command/TransferKey.hs

@@ -24,7 +24,7 @@ def = [withOptions options $
 		"transfers a key from or to a remote"]
 
 options :: [Option]
-options = fileOption : Command.Move.options
+options = [fileOption, Command.Move.fromOption, Command.Move.toOption]
 
 fileOption :: Option
 fileOption = Option.field [] "file" paramFile "the associated file"

Command/TransferKeys.hs

@@ -15,7 +15,6 @@ import Annex.Content
 import Logs.Location
 import Logs.Transfer
 import qualified Remote
-import Types.Remote (AssociatedFile)
 import Types.Key
 import qualified Option