tagging package git-annex version 5.20140421

-----BEGIN PGP SIGNATURE-----
 Version: GnuPG v1
 
 iQIVAwUAU1U938kQ2SIlEuPHAQJHHQ/+J+f3OQdr0Thm1TsJyNHStVnmNbv519My
 VrDpyWEZIW3jQdQ04QUl3GDobouApAQ2KxqKlX8qWcmsDf1YJCz2NlI8GnZFXgz4
 sftiIRWCZDJ8gC+erNfZb0BVcToMDgEAIVQ0+CPuVO1vsuMJzxVCz4w2Pn8qnzvp
 ZDbZeznJB8AaF6nz5uEp2+YrkPwZHcc9+35ToYVBgAFYbNDsE8GKOnLPNBI21EgX
 5z53MZBmrM0P9QfHoG/wjK1vRD0eCi5XKzg3ILb6vesEhuM3XlryQSix5sgm5kzl
 Lt+DKQnx2duM7EroRa6iXOcZGnCUbGZDwRh9j/0EfXh6hg4N5DBXwEB7fHDFKBgI
 f0Yl3e+qQmCIBeFEFbC7GxG6EX71BPMcLHVSiFR9OzjcvjH4I/87CHY7Na8ebCxY
 KeVyF62tvvBEgvNExOzXefa+GV357mkVtPIKS0LMU96T6EkdR++peE4VkYaia/4H
 nRD/gDNckcpy8YKfvXsZaWYPkpHkVmz0fAsoiDdMhNxUgeo5X7pcD97g/LnFWuGb
 Jws34xJcHHr6FTEt54HOXJ1RZMm8L3udQeH7LJok8ipn0XibgEFLcLMwHgOy67R2
 V9K5qoYNLz389/LCBBtAVsQNh2wrY4Znne9zinYKjI/zZqDlpXurN7Wv3klttlVR
 AeMs+MRudsc=
 =TiRQ
 -----END PGP SIGNATURE-----

Merge tag '5.20140421' into debian-wheezy-backport

tagging package git-annex version 5.20140421

# gpg: Signature made Mon Apr 21 11:48:47 2014 JEST using RSA key ID 2512E3C7
# gpg: Good signature from "Joey Hess <joeyh@debian.org>"
# gpg:                 aka "Joey Hess <joey@kitenet.net>"
# gpg:                 aka "Joey Hess <id@joeyh.name>"
# gpg: WARNING: This key is not certified with a trusted signature!
# gpg:          There is no indication that the signature belongs to the owner.
# Primary key fingerprint: E85A 5F63 B31D 24C1 EBF0  D81C C910 D922 2512 E3C7

Annex/Environment.hs

@@ -56,10 +56,12 @@ checkEnvironmentIO =
 #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. -}
+ - sets user.email and user.name 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
+		name <- liftIO myUserName
+		setConfig (ConfigKey "user.name") name
+		setConfig (ConfigKey "user.email") name
 		a

Annex/Index.hs

@@ -9,6 +9,7 @@
 
 module Annex.Index (
 	withIndexFile,
+	addGitEnv,
 ) where
 
 import qualified Control.Exception as E
@@ -23,24 +24,30 @@ import Annex.Exception
 withIndexFile :: FilePath -> Annex a -> Annex a
 withIndexFile f a = do
 	g <- gitRepo
-#ifdef __ANDROID__
+	g' <- liftIO $ addGitEnv g "GIT_INDEX_FILE" f
-	{- This should not be necessary on Android, but there is some
-	 - weird getEnvironment breakage. See
-	 - https://github.com/neurocyte/ghc-android/issues/7
-	 - Use getEnv to get some key environment variables that
-	 - git expects to have. -}
-	let keyenv = words "USER PATH GIT_EXEC_PATH HOSTNAME HOME"
-	let getEnvPair k = maybe Nothing (\v -> Just (k, v)) <$> getEnv k
-	e <- liftIO $ catMaybes <$> forM keyenv getEnvPair
-	let e' = ("GIT_INDEX_FILE", f):e
-#else
-	e <- liftIO getEnvironment
-	let e' = addEntry "GIT_INDEX_FILE" f e
-#endif
-	let g' = g { gitEnv = Just e' }
 
 	r <- tryAnnex $ do
 		Annex.changeState $ \s -> s { Annex.repo = g' }
 		a
 	Annex.changeState $ \s -> s { Annex.repo = (Annex.repo s) { gitEnv = gitEnv g} }
 	either E.throw return r
+
+addGitEnv :: Repo -> String -> String -> IO Repo
+addGitEnv g var val = do
+	e <- maybe copyenv return (gitEnv g)
+	let e' = addEntry var val e
+	return $ g { gitEnv = Just e' }
+  where
+	copyenv = do
+#ifdef __ANDROID__
+		{- This should not be necessary on Android, but there is some
+		 - weird getEnvironment breakage. See
+		 - https://github.com/neurocyte/ghc-android/issues/7
+		 - Use getEnv to get some key environment variables that
+		 - git expects to have. -}
+		let keyenv = words "USER PATH GIT_EXEC_PATH HOSTNAME HOME"
+		let getEnvPair k = maybe Nothing (\v -> Just (k, v)) <$> getEnv k
+		liftIO $ catMaybes <$> forM keyenv getEnvPair
+#else
+		liftIO getEnvironment
+#endif

Annex/Init.hs

@@ -11,6 +11,7 @@ module Annex.Init (
 	ensureInitialized,
 	isInitialized,
 	initialize,
+	initialize',
 	uninitialize,
 	probeCrippledFileSystem,
 ) where
@@ -60,6 +61,17 @@ genDescription Nothing = do
 initialize :: Maybe String -> Annex ()
 initialize mdescription = do
 	prepUUID
+	initialize'
+
+	u <- getUUID
+	{- This will make the first commit to git, so ensure git is set up
+	 - properly to allow commits when running it. -}
+	ensureCommit $ do
+		Annex.Branch.create
+		describeUUID u =<< genDescription mdescription
+
+initialize' :: Annex ()
+initialize' = do
 	checkFifoSupport
 	checkCrippledFileSystem
 	unlessM isBare $
@@ -75,12 +87,6 @@ initialize mdescription = do
 			switchHEADBack
 		)
 	createInodeSentinalFile
-	u <- getUUID
-	{- This will make the first commit to git, so ensure git is set up
-	 - properly to allow commits when running it. -}
-	ensureCommit $ do
-		Annex.Branch.create
-		describeUUID u =<< genDescription mdescription
 
 uninitialize :: Annex ()
 uninitialize = do

Annex/Ssh.hs

@@ -1,6 +1,6 @@
 {- git-annex ssh interface, with connection caching
  -
- - Copyright 2012,2013 Joey Hess <joey@kitenet.net>
+ - Copyright 2012-2014 Joey Hess <joey@kitenet.net>
  -
  - Licensed under the GNU GPL version 3 or higher.
  -}
@@ -11,19 +11,29 @@ module Annex.Ssh (
 	sshCachingOptions,
 	sshCacheDir,
 	sshReadPort,
+	forceSshCleanup,
+	sshCachingEnv,
+	sshCachingTo,
+	inRepoWithSshCachingTo,
+	runSshCaching,
 ) where
 
 import qualified Data.Map as M
 import Data.Hash.MD5
 import System.Process (cwd)
+import System.Exit
 
 import Common.Annex
 import Annex.LockPool
 import qualified Build.SysConfig as SysConfig
 import qualified Annex
+import qualified Git
+import qualified Git.Url
 import Config
+import Config.Files
 import Utility.Env
 import Types.CleanupActions
+import Annex.Index (addGitEnv)
 #ifndef mingw32_HOST_OS
 import Annex.Perms
 #endif
@@ -31,22 +41,13 @@ import Annex.Perms
 {- Generates parameters to ssh to a given host (or user@host) on a given
  - port, with connection caching. -}
 sshCachingOptions :: (String, Maybe Integer) -> [CommandParam] -> Annex [CommandParam]
-sshCachingOptions (host, port) opts = do
+sshCachingOptions (host, port) opts = go =<< sshInfo (host, port)
-	Annex.addCleanup SshCachingCleanup sshCleanup
-	go =<< sshInfo (host, port)
   where
 	go (Nothing, params) = ret params
 	go (Just socketfile, params) = do
-		cleanstale
+		prepSocket socketfile
-		liftIO $ createDirectoryIfMissing True $ parentDir socketfile
-		lockFile $ socket2lock socketfile
 		ret params
 	ret ps = return $ ps ++ opts ++ portParams port ++ [Param "-T"]
-	-- If the lock pool is empty, this is the first ssh of this
-	-- run. There could be stale ssh connections hanging around
-	-- from a previous git-annex run that was interrupted.
-	cleanstale = whenM (not . any isLock . M.keys <$> getPool)
-		sshCleanup
 
 {- Returns a filename to use for a ssh connection caching socket, and
  - parameters to enable ssh connection caching. -}
@@ -102,28 +103,50 @@ sshCacheDir
   where
 	gettmpdir = liftIO $ getEnv "GIT_ANNEX_TMP_DIR"
 	usetmpdir tmpdir = liftIO $ catchMaybeIO $ do
-		createDirectoryIfMissing True tmpdir
+		let socktmp = tmpdir </> "ssh"
-		return tmpdir
+		createDirectoryIfMissing True socktmp
+		return socktmp
 
 portParams :: Maybe Integer -> [CommandParam]
 portParams Nothing = []
 portParams (Just port) = [Param "-p", Param $ show port]
 
-{- Stop any unused ssh processes. -}
+{- Prepare to use a socket file. Locks a lock file to prevent
-sshCleanup :: Annex ()
+ - other git-annex processes from stopping the ssh on this socket. -}
-sshCleanup = go =<< sshCacheDir
+prepSocket :: FilePath -> Annex ()
+prepSocket socketfile = do
+	-- If the lock pool is empty, this is the first ssh of this
+	-- run. There could be stale ssh connections hanging around
+	-- from a previous git-annex run that was interrupted.
+	whenM (not . any isLock . M.keys <$> getPool)
+		sshCleanup
+	-- Cleanup at end of this run.
+	Annex.addCleanup SshCachingCleanup sshCleanup
+
+	liftIO $ createDirectoryIfMissing True $ parentDir socketfile
+	lockFile $ socket2lock socketfile
+
+enumSocketFiles :: Annex [FilePath]
+enumSocketFiles = go =<< sshCacheDir
+  where
+	go Nothing = return []
+	go (Just dir) = liftIO $ filter (not . isLock)
+		<$> catchDefaultIO [] (dirContents dir)
+
+{- Stop any unused ssh connection caching processes. -}
+sshCleanup :: Annex ()
+sshCleanup = mapM_ cleanup =<< enumSocketFiles
   where
-	go Nothing = noop
-	go (Just dir) = do
-		sockets <- liftIO $ filter (not . isLock)
-			<$> catchDefaultIO [] (dirContents dir)
-		forM_ sockets cleanup
 	cleanup socketfile = do
 #ifndef mingw32_HOST_OS
 		-- Drop any shared lock we have, and take an
 		-- exclusive lock, without blocking. If the lock
 		-- succeeds, nothing is using this ssh, and it can
 		-- be stopped.
+		--
+		-- After ssh is stopped cannot remove the lock file;
+		-- other processes may be waiting on our exclusive
+		-- lock to use it.
 		let lockfile = socket2lock socketfile
 		unlockFile lockfile
 		mode <- annexFileMode
@@ -133,24 +156,28 @@ sshCleanup = go =<< sshCacheDir
 			setLock fd (WriteLock, AbsoluteSeek, 0, 0)
 		case v of
 			Left _ -> noop
-			Right _ -> stopssh socketfile
+			Right _ -> forceStopSsh socketfile
 		liftIO $ closeFd fd
 #else
-		stopssh socketfile
+		forceStopSsh socketfile
 #endif
-	stopssh socketfile = do
+
-		let (dir, base) = splitFileName socketfile
+{- Stop all ssh connection caching processes, even when they're in use. -}
-		let params = sshConnectionCachingParams base
+forceSshCleanup :: Annex ()
-		-- "ssh -O stop" is noisy on stderr even with -q
+forceSshCleanup = mapM_ forceStopSsh =<< enumSocketFiles
-		void $ liftIO $ catchMaybeIO $
+
-			withQuietOutput createProcessSuccess $
+forceStopSsh :: FilePath -> Annex ()
-				(proc "ssh" $ toCommand $
+forceStopSsh socketfile = do
-					[ Params "-O stop"
+	let (dir, base) = splitFileName socketfile
-					] ++ params ++ [Param "localhost"])
+	let params = sshConnectionCachingParams base
-					{ cwd = Just dir }
+	-- "ssh -O stop" is noisy on stderr even with -q
-		liftIO $ nukeFile socketfile
+	void $ liftIO $ catchMaybeIO $
-		-- Cannot remove the lock file; other processes may
+		withQuietOutput createProcessSuccess $
-		-- be waiting on our exclusive lock to use it.
+			(proc "ssh" $ toCommand $
+				[ Params "-O stop"
+				] ++ params ++ [Param "localhost"])
+				{ cwd = Just dir }
+	liftIO $ nukeFile socketfile
 
 {- This needs to be as short as possible, due to limitations on the length
  - of the path to a socket file. At the same time, it needs to be unique
@@ -199,3 +226,50 @@ sshReadPort params = (port, reverse args)
 	aux (p,ps) (q:rest) | "-p" `isPrefixOf` q = aux (readPort $ drop 2 q, ps) rest
 			    | otherwise = aux (p,q:ps) rest
 	readPort p = fmap fst $ listToMaybe $ reads p
+
+{- When this env var is set, git-annex runs ssh with parameters
+ - to use the socket file that the env var contains.
+ -
+ - This is a workaround for GiT_SSH not being able to contain
+ - additional parameters to pass to ssh. -}
+sshCachingEnv :: String
+sshCachingEnv = "GIT_ANNEX_SSHCACHING"
+
+{- Enables ssh caching for git push/pull to a particular
+ - remote git repo. (Can safely be used on non-ssh remotes.)
+ -
+ - Like inRepo, the action is run with the local git repo.
+ - But here it's a modified version, with gitEnv to set GIT_SSH=git-annex,
+ - and sshCachingEnv set so that git-annex will know what socket
+ - file to use. -}
+inRepoWithSshCachingTo :: Git.Repo -> (Git.Repo -> IO a) -> Annex a
+inRepoWithSshCachingTo remote a =
+	liftIO . a =<< sshCachingTo remote =<< gitRepo
+
+{- To make any git commands be run with ssh caching enabled, 
+ - alters the local Git.Repo's gitEnv to set GIT_SSH=git-annex,
+ - and set sshCachingEnv so that git-annex will know what socket
+ - file to use. -}
+sshCachingTo :: Git.Repo -> Git.Repo -> Annex Git.Repo
+sshCachingTo remote g 
+	| not (Git.repoIsUrl remote) || Git.repoIsHttp remote = uncached
+	| otherwise = case Git.Url.hostuser remote of
+		Nothing -> uncached
+		Just host -> do
+			(msockfile, _) <- sshInfo (host, Git.Url.port remote)
+			case msockfile of
+				Nothing -> return g
+				Just sockfile -> do
+					command <- liftIO readProgramFile
+					prepSocket sockfile
+					liftIO $ do
+						g' <- addGitEnv g sshCachingEnv sockfile
+						addGitEnv g' "GIT_SSH" command
+  where
+	uncached = return g
+
+runSshCaching :: [String] -> String -> IO ()
+runSshCaching args sockfile = do
+	let args' = toCommand (sshConnectionCachingParams sockfile) ++ args
+	let p = proc "ssh" args'
+	exitWith =<< waitForProcess . processHandle =<< createProcess p

Annex/UUID.hs

@@ -21,6 +21,7 @@ module Annex.UUID (
 	gCryptNameSpace,
 	removeRepoUUID,
 	storeUUID,
+	storeUUIDIn,
 	setUUID,
 ) where
 
@@ -70,7 +71,7 @@ getRepoUUID r = do
   where
 	updatecache u = do
 		g <- gitRepo
-		when (g /= r) $ storeUUID cachekey u
+		when (g /= r) $ storeUUIDIn cachekey u
 	cachekey = remoteConfig r "uuid"
 
 removeRepoUUID :: Annex ()
@@ -84,10 +85,13 @@ getUncachedUUID = toUUID . Git.Config.get key ""
 {- Make sure that the repo has an annex.uuid setting. -}
 prepUUID :: Annex ()
 prepUUID = whenM ((==) NoUUID <$> getUUID) $
-	storeUUID configkey =<< liftIO genUUID
+	storeUUID =<< liftIO genUUID
 
-storeUUID :: ConfigKey -> UUID -> Annex ()
+storeUUID :: UUID -> Annex ()
-storeUUID configfield = setConfig configfield . fromUUID
+storeUUID = storeUUIDIn configkey
+
+storeUUIDIn :: ConfigKey -> UUID -> Annex ()
+storeUUIDIn configfield = setConfig configfield . fromUUID
 
 {- Only sets the configkey in the Repo; does not change .git/config -}
 setUUID :: Git.Repo -> UUID -> IO Git.Repo

Annex/View.hs

@@ -348,7 +348,7 @@ applyView' mkviewedfile getfilemetadata view = do
 			void clean
   where
 	genviewedfiles = viewedFiles view mkviewedfile -- enables memoization
-	go uh hasher f (Just (k, _)) = do
+	go uh hasher f (Just k) = do
 		metadata <- getCurrentMetaData k
 		let metadata' = getfilemetadata f `unionMetaData` metadata
 		forM_ (genviewedfiles f metadata') $ \fv -> do

Assistant.hs

@@ -21,6 +21,7 @@ import Assistant.Threads.Pusher
 import Assistant.Threads.Merger
 import Assistant.Threads.TransferWatcher
 import Assistant.Threads.Transferrer
+import Assistant.Threads.RemoteControl
 import Assistant.Threads.SanityChecker
 import Assistant.Threads.Cronner
 import Assistant.Threads.ProblemFixer
@@ -147,6 +148,7 @@ startDaemon assistant foreground startdelay cannotrun listenhost startbrowser =
 				, assist $ transferWatcherThread
 				, assist $ transferPollerThread
 				, assist $ transfererThread
+				, assist $ remoteControlThread
 				, assist $ daemonStatusThread
 				, assist $ sanityCheckerDailyThread urlrenderer
 				, assist $ sanityCheckerHourlyThread

Assistant/Alert.hs

@@ -16,6 +16,7 @@ import qualified Remote
 import Utility.Tense
 import Logs.Transfer
 import Types.Distribution
+import Git.Types (RemoteName)
 
 import Data.String
 import qualified Data.Text as T
@@ -117,11 +118,14 @@ commitAlert :: Alert
 commitAlert = activityAlert Nothing
 	[Tensed "Committing" "Committed", "changes to git"]
 
-showRemotes :: [Remote] -> TenseChunk
+showRemotes :: [RemoteName] -> TenseChunk
-showRemotes = UnTensed . T.intercalate ", " . map (T.pack . Remote.name)
+showRemotes = UnTensed . T.intercalate ", " . map T.pack
 
 syncAlert :: [Remote] -> Alert
-syncAlert rs = baseActivityAlert
+syncAlert = syncAlert' . map Remote.name
+
+syncAlert' :: [RemoteName] -> Alert
+syncAlert' rs = baseActivityAlert
 	{ alertName = Just SyncAlert
 	, alertHeader = Just $ tenseWords
 		[Tensed "Syncing" "Synced", "with", showRemotes rs]
@@ -130,7 +134,12 @@ syncAlert rs = baseActivityAlert
 	}
 
 syncResultAlert :: [Remote] -> [Remote] -> Alert
-syncResultAlert succeeded failed = makeAlertFiller (not $ null succeeded) $
+syncResultAlert succeeded failed = syncResultAlert'
+	(map Remote.name succeeded)
+	(map Remote.name failed)
+
+syncResultAlert' :: [RemoteName] -> [RemoteName] -> Alert
+syncResultAlert' succeeded failed = makeAlertFiller (not $ null succeeded) $
 	baseActivityAlert
 		{ alertName = Just SyncAlert
 		, alertHeader = Just $ tenseWords msg
@@ -320,10 +329,10 @@ pairRequestAcknowledgedAlert who button = baseActivityAlert
 	, alertButtons = maybeToList button
 	}
 
-xmppNeededAlert :: AlertButton -> Alert
+connectionNeededAlert :: AlertButton -> Alert
-xmppNeededAlert button = Alert
+connectionNeededAlert button = Alert
 	{ alertHeader = Just "Share with friends, and keep your devices in sync across the cloud."
-	, alertIcon = Just TheCloud
+	, alertIcon = Just ConnectionIcon
 	, alertPriority = High
 	, alertButtons = [button]
 	, alertClosable = True
@@ -331,7 +340,7 @@ xmppNeededAlert button = Alert
 	, alertMessageRender = renderData
 	, alertCounter = 0
 	, alertBlockDisplay = True
-	, alertName = Just $ XMPPNeededAlert
+	, alertName = Just ConnectionNeededAlert
 	, alertCombiner = Just $ dataCombiner $ \_old new -> new
 	, alertData = []
 	}

Assistant/DaemonStatus.hs

@@ -26,6 +26,7 @@ import Data.Time.Clock.POSIX
 import Data.Time
 import System.Locale
 import qualified Data.Map as M
+import qualified Data.Set as S
 import qualified Data.Text as T
 
 getDaemonStatus :: Assistant DaemonStatus
@@ -78,6 +79,15 @@ updateSyncRemotes = do
 			M.filter $ \alert ->
 				alertName alert /= Just CloudRepoNeededAlert
 
+changeCurrentlyConnected :: (S.Set UUID -> S.Set UUID) -> Assistant ()
+changeCurrentlyConnected sm = do
+	modifyDaemonStatus_ $ \ds -> ds
+		{ currentlyConnectedRemotes = sm (currentlyConnectedRemotes ds)
+		}
+	v <- currentlyConnectedRemotes <$> getDaemonStatus
+	debug [show v]
+	liftIO . sendNotification =<< syncRemotesNotifier <$> getDaemonStatus
+
 updateScheduleLog :: Assistant ()
 updateScheduleLog =
 	liftIO . sendNotification =<< scheduleLogNotifier <$> getDaemonStatus

Assistant/Install.hs

@@ -30,8 +30,8 @@ standaloneAppBase = getEnv "GIT_ANNEX_APP_BASE"
 
 {- The standalone app does not have an installation process.
  - So when it's run, it needs to set up autostarting of the assistant
- - daemon, as well as writing the programFile, and putting a
+ - daemon, as well as writing the programFile, and putting the
- - git-annex-shell wrapper into ~/.ssh
+ - git-annex-shell and git-annex-wrapper wrapper scripts into ~/.ssh
  -
  - Note that this is done every time it's started, so if the user moves
  - it around, the paths this sets up won't break.
@@ -59,30 +59,35 @@ ensureInstalled = go =<< standaloneAppBase
 #endif
 		installAutoStart program autostartfile
 
-		{- This shim is only updated if it doesn't
-		 - already exist with the right content. -}
 		sshdir <- sshDir
-		let shim = sshdir </> "git-annex-shell"
+		let runshell var = "exec " ++ base </> "runshell " ++ var
-		let runshell var = "exec " ++ base </> "runshell" ++
+		let rungitannexshell var = runshell $ "git-annex-shell -c \"" ++ var ++ "\""
-			" git-annex-shell -c \"" ++ var ++ "\""
+
-		let content = unlines
+		installWrapper (sshdir </> "git-annex-shell") $ unlines
 			[ shebang_local
 			, "set -e"
 			, "if [ \"x$SSH_ORIGINAL_COMMAND\" != \"x\" ]; then"
-			,   runshell "$SSH_ORIGINAL_COMMAND"
+			,   rungitannexshell "$SSH_ORIGINAL_COMMAND"
 			, "else"
-			,   runshell "$@"
+			,   rungitannexshell "$@"
 			, "fi"
 			]
-
+		installWrapper (sshdir </> "git-annex-wrapper") $ unlines
-		curr <- catchDefaultIO "" $ readFileStrict shim
+			[ shebang_local
-		when (curr /= content) $ do
+			, "set -e"
-			createDirectoryIfMissing True (parentDir shim)
+			, runshell "\"$@\""
-			viaTmp writeFile shim content
+			]
-			modifyFileMode shim $ addModes [ownerExecuteMode]
 
 		installNautilus program
 
+installWrapper :: FilePath -> String -> IO ()
+installWrapper file content = do
+	curr <- catchDefaultIO "" $ readFileStrict file
+	when (curr /= content) $ do
+		createDirectoryIfMissing True (parentDir file)
+		viaTmp writeFile file content
+		modifyFileMode file $ addModes [ownerExecuteMode]
+
 installNautilus :: FilePath -> IO ()
 #ifdef linux_HOST_OS
 installNautilus program = do

Assistant/Monad.hs

@@ -43,6 +43,7 @@ import Assistant.Types.RepoProblem
 import Assistant.Types.Buddies
 import Assistant.Types.NetMessager
 import Assistant.Types.ThreadName
+import Assistant.Types.RemoteControl
 
 newtype Assistant a = Assistant { mkAssistant :: ReaderT AssistantData IO a }
 	deriving (
@@ -68,6 +69,7 @@ data AssistantData = AssistantData
 	, branchChangeHandle :: BranchChangeHandle
 	, buddyList :: BuddyList
 	, netMessager :: NetMessager
+	, remoteControl :: RemoteControl
 	}
 
 newAssistantData :: ThreadState -> DaemonStatusHandle -> IO AssistantData
@@ -86,6 +88,7 @@ newAssistantData st dstatus = AssistantData
 	<*> newBranchChangeHandle
 	<*> newBuddyList
 	<*> newNetMessager
+	<*> newRemoteControl
 
 runAssistant :: AssistantData -> Assistant a -> IO a
 runAssistant d a = runReaderT (mkAssistant a) d

Assistant/RemoteControl.hs

@@ -0,0 +1,21 @@
+{- git-annex assistant RemoteDaemon control
+ -
+ - Copyright 2014 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Assistant.RemoteControl (
+	sendRemoteControl,
+	RemoteDaemon.Consumed(..)
+) where
+
+import Assistant.Common
+import qualified RemoteDaemon.Types as RemoteDaemon
+
+import Control.Concurrent
+
+sendRemoteControl :: RemoteDaemon.Consumed -> Assistant ()
+sendRemoteControl msg = do
+	clicker <- getAssistant remoteControl
+	liftIO $ writeChan clicker msg

Assistant/Sync.hs

@@ -15,6 +15,7 @@ import Assistant.Alert
 import Assistant.Alert.Utility
 import Assistant.DaemonStatus
 import Assistant.ScanRemotes
+import Assistant.RemoteControl
 import qualified Command.Sync
 import Utility.Parallel
 import qualified Git
@@ -258,6 +259,7 @@ changeSyncable Nothing enable = do
 changeSyncable (Just r) True = do
 	liftAnnex $ changeSyncFlag r True
 	syncRemote r
+	sendRemoteControl RELOAD
 changeSyncable (Just r) False = do
 	liftAnnex $ changeSyncFlag r False
 	updateSyncRemotes

Assistant/Threads/NetWatcher.hs

@@ -15,13 +15,13 @@ import Assistant.Sync
 import Utility.ThreadScheduler
 import qualified Types.Remote as Remote
 import Assistant.DaemonStatus
+import Assistant.RemoteControl
 import Utility.NotificationBroadcaster
 
 #if WITH_DBUS
 import Utility.DBus
 import DBus.Client
 import DBus
-import Data.Word (Word32)
 import Assistant.NetMessager
 #else
 #ifdef linux_HOST_OS
@@ -44,8 +44,9 @@ netWatcherThread = thread noop
  - while (despite the local network staying up), are synced with
  - periodically.
  -
- - Note that it does not call notifyNetMessagerRestart, because
+ - Note that it does not call notifyNetMessagerRestart, or
- - it doesn't know that the network has changed.
+ - signal the RemoteControl, because it doesn't know that the
+ - network has changed.
  -}
 netWatcherFallbackThread :: NamedThread
 netWatcherFallbackThread = namedThread "NetWatcherFallback" $
@@ -61,16 +62,22 @@ dbusThread = do
   where
 	go client = ifM (checkNetMonitor client)
 		( do
-			listenNMConnections client <~> handleconn
+			callback <- asIO1 connchange
-			listenWicdConnections client <~> handleconn
+			liftIO $ do
+				listenNMConnections client callback
+				listenWicdConnections client callback
 		, do
 			liftAnnex $
 				warning "No known network monitor available through dbus; falling back to polling"
 		)
-	handleconn = do
+	connchange False = do
+		debug ["detected network disconnection"]
+		sendRemoteControl LOSTNET
+	connchange True = do
 		debug ["detected network connection"]
 		notifyNetMessagerRestart
 		handleConnection
+		sendRemoteControl RESUME
 	onerr e _ = do
 		liftAnnex $
 			warning $ "lost dbus connection; falling back to polling (" ++ show e ++ ")"
@@ -95,37 +102,64 @@ checkNetMonitor client = do
 	networkmanager = "org.freedesktop.NetworkManager"
 	wicd = "org.wicd.daemon"
 
-{- Listens for new NetworkManager connections. -}
+{- Listens for NetworkManager connections and diconnections.
-listenNMConnections :: Client -> IO () -> IO ()
+ -
-listenNMConnections client callback =
+ - Connection example (once fully connected):
-	listen client matcher $ \event ->
+ - [Variant {"ActivatingConnection": Variant (ObjectPath "/"), "PrimaryConnection": Variant (ObjectPath "/org/freedesktop/NetworkManager/ActiveConnection/34"), "State": Variant 70}]
-		when (Just True == anyM activeconnection (signalBody event)) $
+ -
-			callback
+ - Disconnection example:
+ - [Variant {"ActiveConnections": Variant []}]
+ -}
+listenNMConnections :: Client -> (Bool -> IO ()) -> IO ()
+listenNMConnections client setconnected =
+	listen client matcher $ \event -> mapM_ handle
+		(map dictionaryItems $ mapMaybe fromVariant $ signalBody event)
   where
 	matcher = matchAny
-		{ matchInterface = Just "org.freedesktop.NetworkManager.Connection.Active"
+		{ matchInterface = Just "org.freedesktop.NetworkManager"
 		, matchMember = Just "PropertiesChanged"
 		}
-	nm_connection_activated = toVariant (2 :: Word32)
+	nm_active_connections_key = toVariant ("ActiveConnections" :: String)
-	nm_state_key = toVariant ("State" :: String)
+	nm_activatingconnection_key = toVariant ("ActivatingConnection" :: String)
-	activeconnection v = do
+	noconnections = Just $ toVariant $ toVariant ([] :: [ObjectPath])
-		m <- fromVariant v
+	rootconnection = Just $ toVariant $ toVariant $ objectPath_ "/"
-		vstate <- lookup nm_state_key $ dictionaryItems m
+	handle m
-		state <- fromVariant vstate
+		| lookup nm_active_connections_key m == noconnections =
-		return $ state == nm_connection_activated
+			setconnected False
+		| lookup nm_activatingconnection_key m == rootconnection =
+			setconnected True
+		| otherwise = noop
 
-{- Listens for new Wicd connections. -}
+{- Listens for Wicd connections and disconnections.
-listenWicdConnections :: Client -> IO () -> IO ()
+ -
-listenWicdConnections client callback =
+ - Connection example:
-	listen client matcher $ \event ->
+ -   ConnectResultsSent:
+ -     Variant "success"
+ -
+ - Diconnection example:
+ -   StatusChanged
+ -     [Variant 0, Variant [Varient ""]]
+ -}
+listenWicdConnections :: Client -> (Bool -> IO ()) -> IO ()
+listenWicdConnections client setconnected = do
+	listen client connmatcher $ \event ->
 		when (any (== wicd_success) (signalBody event)) $
-			callback
+			setconnected True
+	listen client statusmatcher $ \event -> handle (signalBody event)
   where
-	matcher = matchAny
+	connmatcher = matchAny
 		{ matchInterface = Just "org.wicd.daemon"
 		, matchMember = Just "ConnectResultsSent"
 		}
+	statusmatcher = matchAny
+		{ matchInterface = Just "org.wicd.daemon"
+		, matchMember = Just "StatusChanged"
+		}
 	wicd_success = toVariant ("success" :: String)
+	wicd_disconnected = toVariant [toVariant ("" :: String)]
+	handle status
+		| any (== wicd_disconnected) status = setconnected False
+		| otherwise = noop
 
 #endif
 

Assistant/Threads/RemoteControl.hs

@@ -0,0 +1,122 @@
+{- git-annex assistant communication with remotedaemon
+ -
+ - Copyright 2014 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Assistant.Threads.RemoteControl where
+
+import Assistant.Common
+import RemoteDaemon.Types
+import Config.Files
+import Utility.Batch
+import Utility.SimpleProtocol
+import Assistant.Alert
+import Assistant.Alert.Utility
+import Assistant.DaemonStatus
+import qualified Git
+import qualified Git.Types as Git
+import qualified Remote
+import qualified Types.Remote as Remote
+
+import Control.Concurrent
+import Control.Concurrent.Async
+import System.Process (std_in, std_out)
+import Network.URI
+import qualified Data.Map as M
+import qualified Data.Set as S
+
+remoteControlThread :: NamedThread
+remoteControlThread = namedThread "RemoteControl" $ do
+	program <- liftIO readProgramFile
+	(cmd, params) <- liftIO $ toBatchCommand
+		(program, [Param "remotedaemon"])
+	let p = proc cmd (toCommand params)
+	(Just toh, Just fromh, _, pid) <- liftIO $ createProcess p
+		{ std_in = CreatePipe
+		, std_out = CreatePipe
+		}
+	
+	urimap <- liftIO . newMVar =<< liftAnnex getURIMap
+
+	controller <- asIO $ remoteControllerThread toh
+	responder <- asIO $ remoteResponderThread fromh urimap
+
+	-- run controller and responder until the remotedaemon dies
+	liftIO $ void $ tryNonAsync $ controller `concurrently` responder
+	debug ["remotedaemon exited"]
+	liftIO $ forceSuccessProcess p pid
+
+-- feed from the remoteControl channel into the remotedaemon
+remoteControllerThread :: Handle -> Assistant ()
+remoteControllerThread toh = do
+	clicker <- getAssistant remoteControl
+	forever $ do
+		msg <- liftIO $ readChan clicker
+		debug [show msg]
+		liftIO $ do
+			hPutStrLn toh $ unwords $ formatMessage msg
+			hFlush toh
+
+-- read status messages emitted by the remotedaemon and handle them
+remoteResponderThread :: Handle -> MVar (M.Map URI Remote) -> Assistant ()
+remoteResponderThread fromh urimap = go M.empty
+  where
+	go syncalerts = do
+		l <- liftIO $ hGetLine fromh
+		debug [l]
+		case parseMessage l of
+			Just (CONNECTED uri) -> changeconnected S.insert uri
+			Just (DISCONNECTED uri) -> changeconnected S.delete uri
+			Just (SYNCING uri) -> withr uri $ \r ->
+				if M.member (Remote.uuid r) syncalerts
+					then go syncalerts
+					else do
+						i <- addAlert $ syncAlert [r]
+						go (M.insert (Remote.uuid r) i syncalerts)
+			Just (DONESYNCING uri status) -> withr uri $ \r ->
+				case M.lookup (Remote.uuid r) syncalerts of
+					Nothing -> cont
+					Just i -> do
+						let (succeeded, failed) = if status
+							then ([r], [])
+							else ([], [r])
+						updateAlertMap $ mergeAlert i $
+							syncResultAlert succeeded failed
+						go (M.delete (Remote.uuid r) syncalerts)
+			Just (WARNING (RemoteURI uri) msg) -> do
+				void $ addAlert $
+					warningAlert ("RemoteControl "++ show uri) msg
+				cont
+			Nothing -> do
+				debug ["protocol error from remotedaemon: ", l]
+				cont
+	  where
+		cont = go syncalerts
+		withr uri = withRemote uri urimap cont
+		changeconnected sm uri = withr uri $ \r -> do
+			changeCurrentlyConnected $ sm $ Remote.uuid r
+			cont
+
+getURIMap :: Annex (M.Map URI Remote)
+getURIMap = Remote.remoteMap' id (mkk . Git.location . Remote.repo)
+  where
+	mkk (Git.Url u) = Just u
+	mkk _ = Nothing
+
+withRemote
+	:: RemoteURI
+	-> MVar (M.Map URI Remote)
+	-> Assistant a
+	-> (Remote -> Assistant a)
+	-> Assistant a
+withRemote (RemoteURI uri) remotemap noremote a = do
+	m <- liftIO $ readMVar remotemap
+	case M.lookup uri m of
+		Just r -> a r
+		Nothing -> do
+			{- Reload map, in case a new remote has been added. -}
+			m' <- liftAnnex getURIMap
+			void $ liftIO $ swapMVar remotemap $ m'
+			maybe noremote a (M.lookup uri m')

Assistant/Threads/TransferScanner.hs

@@ -151,7 +151,7 @@ expensiveScan urlrenderer rs = unless onlyweb $ batch <~> do
 	enqueue f (r, t) =
 		queueTransferWhenSmall "expensive scan found missing object"
 			(Just f) t r
-	findtransfers f unwanted (key, _) = do
+	findtransfers f unwanted key = do
 		{- The syncable remotes may have changed since this
 		 - scan began. -}
 		syncrs <- syncDataRemotes <$> getDaemonStatus

Assistant/Threads/Watcher.hs

@@ -271,7 +271,7 @@ onAddSymlink :: Bool -> Handler
 onAddSymlink isdirect file filestatus = unlessIgnored file $ do
 	linktarget <- liftIO (catchMaybeIO $ readSymbolicLink file)
 	kv <- liftAnnex (Backend.lookupFile file)
-	onAddSymlink' linktarget (fmap fst kv) isdirect file filestatus
+	onAddSymlink' linktarget kv isdirect file filestatus
 
 onAddSymlink' :: Maybe String -> Maybe Key -> Bool -> Handler
 onAddSymlink' linktarget mk isdirect file filestatus = go mk

Assistant/Threads/XMPPClient.hs

@@ -42,17 +42,20 @@ xmppClientThread urlrenderer = namedThread "XMPPClient" $
 	restartableClient . xmppClient urlrenderer =<< getAssistant id
 
 {- Runs the client, handing restart events. -}
-restartableClient :: (XMPPCreds -> IO ()) -> Assistant ()
+restartableClient :: (XMPPCreds -> UUID -> IO ()) -> Assistant ()
 restartableClient a = forever $ go =<< liftAnnex getXMPPCreds
   where
 	go Nothing = waitNetMessagerRestart
 	go (Just creds) = do
-		tid <- liftIO $ forkIO $ a creds
+		xmppuuid <- maybe NoUUID Remote.uuid . headMaybe 
+			. filter Remote.isXMPPRemote . syncRemotes
+			<$> getDaemonStatus
+		tid <- liftIO $ forkIO $ a creds xmppuuid
 		waitNetMessagerRestart
 		liftIO $ killThread tid
 
-xmppClient :: UrlRenderer -> AssistantData -> XMPPCreds -> IO ()
+xmppClient :: UrlRenderer -> AssistantData -> XMPPCreds -> UUID -> IO ()
-xmppClient urlrenderer d creds =
+xmppClient urlrenderer d creds xmppuuid =
 	retry (runclient creds) =<< getCurrentTime
   where
 	liftAssistant = runAssistant d
@@ -68,8 +71,11 @@ xmppClient urlrenderer d creds =
 		liftAssistant $
 			updateBuddyList (const noBuddies) <<~ buddyList
 		void client
-		liftAssistant $ modifyDaemonStatus_ $ \s -> s
+		liftAssistant $ do
-			{ xmppClientID = Nothing }
+			modifyDaemonStatus_ $ \s -> s
+				{ xmppClientID = Nothing }
+			changeCurrentlyConnected $ S.delete xmppuuid
+			
 		now <- getCurrentTime
 		if diffUTCTime now starttime > 300
 			then do
@@ -87,6 +93,7 @@ xmppClient urlrenderer d creds =
 		inAssistant $ do
 			modifyDaemonStatus_ $ \s -> s
 				{ xmppClientID = Just $ xmppJID creds }
+			changeCurrentlyConnected $ S.insert xmppuuid
 			debug ["connected", logJid selfjid]
 
 		lasttraffic <- liftIO $ atomically . newTMVar =<< getCurrentTime

Assistant/Types/Alert.hs

@@ -26,7 +26,7 @@ data AlertName
 	| SanityCheckFixAlert
 	| WarningAlert String
 	| PairAlert String
-	| XMPPNeededAlert
+	| ConnectionNeededAlert
 	| RemoteRemovalAlert String
 	| CloudRepoNeededAlert
 	| SyncAlert
@@ -54,7 +54,7 @@ data Alert = Alert
 	, alertButtons :: [AlertButton]
 	}
 
-data AlertIcon = ActivityIcon | SyncIcon | SuccessIcon | ErrorIcon | InfoIcon | UpgradeIcon | TheCloud
+data AlertIcon = ActivityIcon | SyncIcon | SuccessIcon | ErrorIcon | InfoIcon | UpgradeIcon | ConnectionIcon
 
 type AlertMap = M.Map AlertId Alert
 

Assistant/Types/DaemonStatus.hs

@@ -52,6 +52,8 @@ data DaemonStatus = DaemonStatus
 	, syncDataRemotes :: [Remote]
 	-- Are we syncing to any cloud remotes?
 	, syncingToCloudRemote :: Bool
+	-- Set of uuids of remotes that are currently connected.
+	, currentlyConnectedRemotes :: S.Set UUID
 	-- List of uuids of remotes that we may have gotten out of sync with.
 	, desynced :: S.Set UUID
 	-- Pairing request that is in progress.
@@ -104,6 +106,7 @@ newDaemonStatus = DaemonStatus
 	<*> pure []
 	<*> pure False
 	<*> pure S.empty
+	<*> pure S.empty
 	<*> pure Nothing
 	<*> newNotificationBroadcaster
 	<*> newNotificationBroadcaster

Assistant/Types/RemoteControl.hs

@@ -0,0 +1,16 @@
+{- git-annex assistant RemoteDaemon control
+ -
+ - Copyright 2014 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Assistant.Types.RemoteControl where
+
+import qualified RemoteDaemon.Types as RemoteDaemon
+import Control.Concurrent
+
+type RemoteControl = Chan RemoteDaemon.Consumed
+
+newRemoteControl :: IO RemoteControl
+newRemoteControl = newChan

Assistant/WebApp/Configurators.hs

@@ -39,6 +39,14 @@ makeMiscRepositories = $(widgetFile "configurators/addrepository/misc")
 makeCloudRepositories :: Widget
 makeCloudRepositories = $(widgetFile "configurators/addrepository/cloud")
 
+makeXMPPConnection :: Widget
+makeXMPPConnection = $(widgetFile "configurators/addrepository/xmppconnection")
+
+makeSshRepository :: Widget
+makeSshRepository = $(widgetFile "configurators/addrepository/ssh")
+
+makeConnectionRepositories :: Widget
+makeConnectionRepositories = $(widgetFile "configurators/addrepository/connection")
+
 makeArchiveRepositories :: Widget
 makeArchiveRepositories = $(widgetFile "configurators/addrepository/archive")
-

Assistant/WebApp/Configurators/Delete.hs

@@ -39,13 +39,21 @@ notCurrentRepo uuid a = do
   	go Nothing = error "Unknown UUID"
 	go (Just _) = a
 
+handleXMPPRemoval :: UUID -> Handler Html -> Handler Html
+handleXMPPRemoval uuid nonxmpp = do
+	remote <- fromMaybe (error "unknown remote")
+		<$> liftAnnex (Remote.remoteFromUUID uuid)
+	if Remote.isXMPPRemote remote
+		then deletionPage $ $(widgetFile "configurators/delete/xmpp")
+		else nonxmpp
+
 getDisableRepositoryR :: UUID -> Handler Html
-getDisableRepositoryR uuid = notCurrentRepo uuid $ do
+getDisableRepositoryR uuid = notCurrentRepo uuid $ handleXMPPRemoval uuid $ do
 	void $ liftAssistant $ disableRemote uuid
 	redirect DashboardR
 
 getDeleteRepositoryR :: UUID -> Handler Html
-getDeleteRepositoryR uuid = notCurrentRepo uuid $
+getDeleteRepositoryR uuid = notCurrentRepo uuid $ handleXMPPRemoval uuid $ do
 	deletionPage $ do
 		reponame <- liftAnnex $ Remote.prettyUUID uuid
 		$(widgetFile "configurators/delete/start")

Assistant/WebApp/Configurators/Edit.hs

@@ -11,11 +11,12 @@ module Assistant.WebApp.Configurators.Edit where
 
 import Assistant.WebApp.Common
 import Assistant.WebApp.Gpg
+import Assistant.WebApp.Configurators
 import Assistant.DaemonStatus
 import Assistant.WebApp.MakeRemote (uniqueRemoteName)
-import Assistant.WebApp.Configurators.XMPP (xmppNeeded)
 import Assistant.ScanRemotes
 import Assistant.Sync
+import Assistant.Alert
 import qualified Assistant.WebApp.Configurators.AWS as AWS
 import qualified Assistant.WebApp.Configurators.IA as IA
 #ifdef WITH_S3
@@ -183,7 +184,7 @@ getEditNewCloudRepositoryR :: UUID -> Handler Html
 getEditNewCloudRepositoryR = postEditNewCloudRepositoryR
 
 postEditNewCloudRepositoryR :: UUID -> Handler Html
-postEditNewCloudRepositoryR uuid = xmppNeeded >> editForm True (RepoUUID uuid)
+postEditNewCloudRepositoryR uuid = connectionNeeded >> editForm True (RepoUUID uuid)
 
 editForm :: Bool -> RepoId -> Handler Html
 editForm new (RepoUUID uuid) = page "Edit repository" (Just Configuration) $ do
@@ -275,3 +276,23 @@ getUpgradeRepositoryR r = go =<< liftAnnex (repoIdRemote r)
 		liftAssistant updateSyncRemotes
 		liftAssistant $ syncRemote rmt
 		redirect DashboardR
+
+{- If there is no currently connected remote, display an alert suggesting
+ - to set up one. -}
+connectionNeeded :: Handler ()
+connectionNeeded = whenM noconnection $ do
+	urlrender <- getUrlRender
+	void $ liftAssistant $ do
+		close <- asIO1 removeAlert
+		addAlert $ connectionNeededAlert $ AlertButton
+			{ buttonLabel = "Connnect"
+			, buttonUrl = urlrender ConnectionNeededR
+			, buttonAction = Just close
+			, buttonPrimary = True
+			}
+  where
+	noconnection = S.null . currentlyConnectedRemotes <$> liftAssistant getDaemonStatus
+
+getConnectionNeededR :: Handler Html
+getConnectionNeededR = page "Connection needed" (Just Configuration) $ do
+	$(widgetFile "configurators/needconnection")

Assistant/WebApp/Configurators/Ssh.hs

@@ -24,6 +24,7 @@ import Git.Types (RemoteName)
 import qualified Remote.GCrypt as GCrypt
 import Annex.UUID
 import Logs.UUID
+import Assistant.RemoteControl
 
 #ifdef mingw32_HOST_OS
 import Utility.Tmp
@@ -155,7 +156,7 @@ postEnableSshGCryptR :: UUID -> Handler Html
 postEnableSshGCryptR u = whenGcryptInstalled $
 	enableSpecialSshRemote getsshinput enableRsyncNetGCrypt enablegcrypt u
   where
-  	enablegcrypt sshdata _ = prepSsh True sshdata $ \sshdata' ->
+  	enablegcrypt sshdata _ = prepSsh False sshdata $ \sshdata' ->
 		sshConfigurator $
 			checkExistingGCrypt sshdata' $
 				error "Expected to find an encrypted git repository, but did not."
@@ -194,6 +195,16 @@ enableSpecialSshRemote getsshinput rsyncnetsetup genericsetup u = do
 		description <- liftAnnex $ T.pack <$> prettyUUID u
 		$(widgetFile "configurators/ssh/enable")
 
+{- To deal with git-annex and possibly even git and rsync not being
+ - available in the remote server's PATH, when git-annex was installed
+ - from the standalone tarball etc, look for a ~/.ssh/git-annex-wrapper
+ - and if it's there, use it to run a command. -}
+wrapCommand :: String -> String
+wrapCommand cmd = "if [ -x " ++ commandWrapper ++ " ]; then " ++ commandWrapper ++ " " ++ cmd ++ "; else " ++ cmd ++ "; fi"
+
+commandWrapper :: String
+commandWrapper = "~/.ssh/git-annex-wrapper"
+
 {- Test if we can ssh into the server.
  -
  - Two probe attempts are made. First, try sshing in using the existing
@@ -203,8 +214,11 @@ enableSpecialSshRemote getsshinput rsyncnetsetup genericsetup u = do
  -
  - Once logged into the server, probe to see if git-annex-shell,
  - git, and rsync are available. 
+ -
  - Note that, ~/.ssh/git-annex-shell may be
  - present, while git-annex-shell is not in PATH.
+ - Also, git and rsync may not be in PATH; as long as the commandWrapper
+ - is present, assume it is able to be used to run them.
  -
  - Also probe to see if there is already a git repository at the location
  - with either an annex-uuid or a gcrypt-id set. (If not, returns NoUUID.)
@@ -235,6 +249,7 @@ testServer sshinput@(SshInput { inputHostname = Just hn }) = do
 			, checkcommand "git"
 			, checkcommand "rsync"
 			, checkcommand shim
+			, checkcommand commandWrapper
 			, getgitconfig (T.unpack <$> inputDirectory sshinput)
 			]
 		knownhost <- knownHost hn
@@ -257,6 +272,8 @@ testServer sshinput@(SshInput { inputHostname = Just hn }) = do
 			, (shim, GitAnnexShellCapable)
 			, ("git", GitCapable)
 			, ("rsync", RsyncCapable)
+			, (commandWrapper, GitCapable)
+			, (commandWrapper, RsyncCapable)
 			]
 		    u = fromMaybe NoUUID $ headMaybe $ mapMaybe finduuid $
 			map (separate (== '=')) $ lines s
@@ -275,7 +292,7 @@ testServer sshinput@(SshInput { inputHostname = Just hn }) = do
 	
 	checkcommand c = "if which " ++ c ++ "; then " ++ report c ++ "; fi"
 	token r = "git-annex-probe " ++ r
-	report r = "echo " ++ token r
+	report r = "echo " ++ shellEscape (token r)
 	shim = "~/.ssh/git-annex-shell"
 	getgitconfig (Just d)
 		| not (null d) = "cd " ++ shellEscape d ++ " && git config --list"
@@ -294,7 +311,8 @@ showSshErr :: String -> Handler Html
 showSshErr msg = sshConfigurator $
 	$(widgetFile "configurators/ssh/error")
 
-{- The UUID will be NoUUID when the repository does not already exist. -}
+{- The UUID will be NoUUID when the repository does not already exist,
+ - or was not a git-annex repository before. -}
 getConfirmSshR :: SshData -> UUID -> Handler Html
 getConfirmSshR sshdata u
 	| u == NoUUID = handlenew
@@ -328,8 +346,9 @@ getRetrySshR sshdata = do
 	s <- liftIO $ testServer $ mkSshInput sshdata
 	redirect $ either (const $ ConfirmSshR sshdata NoUUID) (uncurry ConfirmSshR) s
 
+{- Making a new git repository. -}
 getMakeSshGitR :: SshData -> Handler Html
-getMakeSshGitR sshdata = prepSsh False sshdata makeSshRepo
+getMakeSshGitR sshdata = prepSsh True sshdata makeSshRepo
 
 getMakeSshRsyncR :: SshData -> Handler Html
 getMakeSshRsyncR sshdata = prepSsh False (rsyncOnly sshdata) makeSshRepo
@@ -341,7 +360,7 @@ getMakeSshGCryptR :: SshData -> RepoKey -> Handler Html
 getMakeSshGCryptR sshdata NoRepoKey = whenGcryptInstalled $
 	withNewSecretKey $ getMakeSshGCryptR sshdata . RepoKey
 getMakeSshGCryptR sshdata (RepoKey keyid) = whenGcryptInstalled $
-	prepSsh True sshdata $ makeGCryptRepo keyid
+	prepSsh False sshdata $ makeGCryptRepo keyid
 	
 {- Detect if the user entered a location with an existing, known
  - gcrypt repository, and enable it. Otherwise, runs the action. -}
@@ -373,18 +392,18 @@ combineExistingGCrypt sshdata u = do
 
 {- Sets up remote repository for ssh, or directory for rsync. -}
 prepSsh :: Bool -> SshData -> (SshData -> Handler Html) -> Handler Html
-prepSsh newgcrypt sshdata a
+prepSsh needsinit sshdata a
 	| needsPubKey sshdata = do
 		keypair <- liftIO genSshKeyPair
 		sshdata' <- liftIO $ setupSshKeyPair keypair sshdata
-		prepSsh' newgcrypt sshdata sshdata' (Just keypair) a
+		prepSsh' needsinit sshdata sshdata' (Just keypair) a
 	| sshPort sshdata /= 22 = do
 		sshdata' <- liftIO $ setSshConfig sshdata []
-		prepSsh' newgcrypt sshdata sshdata' Nothing a
+		prepSsh' needsinit sshdata sshdata' Nothing a
-	| otherwise = prepSsh' newgcrypt sshdata sshdata Nothing a
+	| otherwise = prepSsh' needsinit sshdata sshdata Nothing a
 
 prepSsh' :: Bool -> SshData -> SshData -> Maybe SshKeyPair -> (SshData -> Handler Html) -> Handler Html
-prepSsh' newgcrypt origsshdata sshdata keypair a = sshSetup
+prepSsh' needsinit origsshdata sshdata keypair a = sshSetup
 	 [ "-p", show (sshPort origsshdata)
 	 , genSshHost (sshHostName origsshdata) (sshUserName origsshdata)
 	 , remoteCommand
@@ -394,8 +413,14 @@ prepSsh' newgcrypt origsshdata sshdata keypair a = sshSetup
 	remoteCommand = shellWrap $ intercalate "&&" $ catMaybes
 		[ Just $ "mkdir -p " ++ shellEscape remotedir
 		, Just $ "cd " ++ shellEscape remotedir
-		, if rsynconly then Nothing else Just "if [ ! -d .git ]; then git init --bare --shared && git config receive.denyNonFastforwards false; fi"
+		, if rsynconly then Nothing else Just $ unwords
-		, if rsynconly || newgcrypt then Nothing else Just "git annex init"
+			[ "if [ ! -d .git ]; then"
+			, wrapCommand "git init --bare --shared"
+		, "&&"
+			, wrapCommand "git config receive.denyNonFastforwards"
+			, ";fi"
+			]
+		, if needsinit then Just (wrapCommand "git annex init") else Nothing
 		, if needsPubKey origsshdata
 			then addAuthorizedKeysCommand (hasCapability origsshdata GitAnnexShellCapable) remotedir . sshPubKey <$> keypair
 			else Nothing
@@ -403,11 +428,21 @@ prepSsh' newgcrypt origsshdata sshdata keypair a = sshSetup
 	rsynconly = onlyCapability origsshdata RsyncCapable
 
 makeSshRepo :: SshData -> Handler Html
-makeSshRepo sshdata = setupCloudRemote TransferGroup Nothing $
+makeSshRepo sshdata
-	makeSshRemote sshdata
+	| onlyCapability sshdata RsyncCapable = setupCloudRemote TransferGroup Nothing go
+	| otherwise = makeSshRepoConnection go
+  where
+	go = makeSshRemote sshdata
+
+makeSshRepoConnection :: Annex RemoteName -> Handler Html
+makeSshRepoConnection a = setupRemote postsetup TransferGroup Nothing a
+  where
+	postsetup u = do
+		liftAssistant $ sendRemoteControl RELOAD
+		redirect $ EditNewRepositoryR u
 
 makeGCryptRepo :: KeyId -> SshData -> Handler Html
-makeGCryptRepo keyid sshdata = setupCloudRemote TransferGroup Nothing $ 
+makeGCryptRepo keyid sshdata = makeSshRepoConnection $ 
 	makeGCryptRemote (sshRepoName sshdata) (genSshUrl sshdata) keyid
 
 getAddRsyncNetR :: Handler Html

Assistant/WebApp/Configurators/XMPP.hs

@@ -25,6 +25,9 @@ import Assistant.WebApp.RepoList
 import Assistant.WebApp.Configurators
 import Assistant.XMPP
 #endif
+import qualified Git.Remote
+import Remote.List
+import Creds
 
 #ifdef WITH_XMPP
 import Network.Protocol.XMPP
@@ -32,23 +35,6 @@ import Network
 import qualified Data.Text as T
 #endif
 
-{- Displays an alert suggesting to configure XMPP. -}
-xmppNeeded :: Handler ()
-#ifdef WITH_XMPP
-xmppNeeded = whenM (isNothing <$> liftAnnex getXMPPCreds) $ do
-	urlrender <- getUrlRender
-	void $ liftAssistant $ do
-		close <- asIO1 removeAlert
-		addAlert $ xmppNeededAlert $ AlertButton
-			{ buttonLabel = "Configure a Jabber account"
-			, buttonUrl = urlrender XMPPConfigR
-			, buttonAction = Just close
-			, buttonPrimary = True
-			}
-#else
-xmppNeeded = return ()
-#endif
-
 {- When appropriate, displays an alert suggesting to configure a cloud repo
  - to suppliment an XMPP remote. -}
 checkCloudRepos :: UrlRenderer -> Remote -> Assistant ()
@@ -219,5 +205,22 @@ testXMPP creds = do
 	showport (UnixSocket s) = s
 #endif
 
+getDisconnectXMPPR :: Handler Html
+getDisconnectXMPPR = do
+#ifdef WITH_XMPP
+	rs <- filter Remote.isXMPPRemote . syncRemotes
+		<$> liftAssistant getDaemonStatus
+	liftAnnex $ do
+		mapM_ (inRepo . Git.Remote.remove . Remote.name) rs
+		void remoteListRefresh
+		removeCreds xmppCredsFile
+	liftAssistant $ do
+		updateSyncRemotes
+		notifyNetMessagerRestart
+	redirect DashboardR
+#else
+	xmppPage $ $(widgetFile "configurators/xmpp/disabled")
+#endif
+
 xmppPage :: Widget -> Handler Html
 xmppPage = page "Jabber" (Just Configuration)

Assistant/WebApp/MakeRemote.hs

@@ -26,12 +26,18 @@ import Utility.Yesod
 
 {- Runs an action that creates or enables a cloud remote,
  - and finishes setting it up, then starts syncing with it,
- - and finishes by displaying the page to edit it. -}
+ - and finishes by displaying the page to edit it.
+ -
+ - This includes displaying the connectionNeeded nudge if appropariate.
+ -}
 setupCloudRemote :: StandardGroup -> Maybe Cost -> Annex RemoteName -> Handler a
-setupCloudRemote defaultgroup mcost name = do
+setupCloudRemote = setupRemote $ redirect . EditNewCloudRepositoryR
-	r <- liftAnnex $ addRemote name
+
+setupRemote :: (UUID -> Handler a) -> StandardGroup -> Maybe Cost -> Annex RemoteName -> Handler a
+setupRemote postsetup defaultgroup mcost getname = do
+	r <- liftAnnex $ addRemote getname
 	liftAnnex $ do
 		setStandardGroup (Remote.uuid r) defaultgroup
 		maybe noop (Config.setRemoteCost (Remote.repo r)) mcost
 	liftAssistant $ syncRemote r
-	redirect $ EditNewCloudRepositoryR $ Remote.uuid r
+	postsetup $ Remote.uuid r

Assistant/WebApp/RepoList.hs

@@ -33,9 +33,10 @@ import qualified Data.Text as T
 import Data.Function
 import Control.Concurrent
 
-type RepoList = [(RepoDesc, RepoId, Actions)]
+type RepoList = [(RepoDesc, RepoId, CurrentlyConnected, Actions)]
 
 type RepoDesc = String
+type CurrentlyConnected = Bool
 
 {- Actions that can be performed on a repo in the list. -}
 data Actions
@@ -192,13 +193,19 @@ repoList reposelector
 	  where
 	  	getconfig k = M.lookup k =<< M.lookup u m
 		val iscloud r = Just (iscloud, (RepoUUID u, DisabledRepoActions $ r u))
-	list l = liftAnnex $
+	list l = do
+		cc <- currentlyConnectedRemotes <$> liftAssistant getDaemonStatus
 		forM (nubBy ((==) `on` fst) l) $ \(repoid, actions) ->
-			(,,)
+			(,,,)
-				<$> describeRepoId repoid
+				<$> liftAnnex (describeRepoId repoid)
 				<*> pure repoid
+				<*> pure (getCurrentlyConnected repoid cc)
 				<*> pure actions
 
+getCurrentlyConnected :: RepoId -> S.Set UUID -> CurrentlyConnected
+getCurrentlyConnected (RepoUUID u) cc = S.member u cc
+getCurrentlyConnected _ _ = False
+
 getEnableSyncR :: RepoId -> Handler ()
 getEnableSyncR = flipSync True
 

Assistant/WebApp/SideBar.hs

@@ -103,8 +103,7 @@ htmlIcon InfoIcon = bootstrapIcon "info-sign"
 htmlIcon SuccessIcon = bootstrapIcon "ok"
 htmlIcon ErrorIcon = bootstrapIcon "exclamation-sign"
 htmlIcon UpgradeIcon = bootstrapIcon "arrow-up"
--- utf-8 umbrella (utf-8 cloud looks too stormy)
+htmlIcon ConnectionIcon = bootstrapIcon "signal"
-htmlIcon TheCloud = [whamlet|☂|]
 
 bootstrapIcon :: Text -> Widget
 bootstrapIcon name = [whamlet|<i .icon-#{name}></i>|]

Assistant/WebApp/routes

@@ -20,6 +20,8 @@
 /config/xmpp/for/self XMPPConfigForPairSelfR GET POST
 /config/xmpp/for/frield XMPPConfigForPairFriendR GET POST
 /config/xmpp/needcloudrepo/#UUID NeedCloudRepoR GET
+/config/xmpp/disconnect DisconnectXMPPR GET
+/config/needconnection ConnectionNeededR GET
 /config/fsck ConfigFsckR GET POST
 /config/fsck/preferences ConfigFsckPreferencesR POST
 /config/upgrade/start/#GitAnnexDistribution ConfigStartUpgradeR GET

Assistant/XMPP/Git.hs

@@ -74,7 +74,7 @@ makeXMPPGitRemote :: String -> JID -> UUID -> Assistant Bool
 makeXMPPGitRemote buddyname jid u = do
 	remote <- liftAnnex $ addRemote $
 		makeGitRemote buddyname $ gitXMPPLocation jid
-	liftAnnex $ storeUUID (remoteConfig (Remote.repo remote) "uuid") u
+	liftAnnex $ storeUUIDIn (remoteConfig (Remote.repo remote) "uuid") u
 	liftAnnex $ void remoteListRefresh
 	remote' <- liftAnnex $ fromMaybe (error "failed to add remote")
 		<$> Remote.byName (Just buddyname)

Backend.hs

@@ -1,6 +1,6 @@
 {- git-annex key/value backends
  -
- - Copyright 2010,2013 Joey Hess <joey@kitenet.net>
+ - Copyright 2010-2014 Joey Hess <joey@kitenet.net>
  -
  - Licensed under the GNU GPL version 3 or higher.
  -}
@@ -10,6 +10,7 @@ module Backend (
 	orderedList,
 	genKey,
 	lookupFile,
+	getBackend,
 	isAnnexLink,
 	chooseBackend,
 	lookupBackendName,
@@ -74,7 +75,7 @@ genKey' (b:bs) source = do
 		| c == '\n' = '_'
 		| otherwise = c
 
-{- Looks up the key and backend corresponding to an annexed file,
+{- Looks up the key corresponding to an annexed file,
  - by examining what the file links to.
  -
  - In direct mode, there is often no link on disk, in which case
@@ -82,7 +83,7 @@ genKey' (b:bs) source = do
  - on disk still takes precedence over what was committed to git in direct
  - mode.
  -}
-lookupFile :: FilePath -> Annex (Maybe (Key, Backend))
+lookupFile :: FilePath -> Annex (Maybe Key)
 lookupFile file = do
 	mkey <- isAnnexLink file
 	case mkey of
@@ -92,14 +93,15 @@ lookupFile file = do
 			, return Nothing
 			)
   where
-	makeret k = let bname = keyBackendName k in
+	makeret k = return $ Just k
-		case maybeLookupBackendName bname of
+
-			Just backend -> return $ Just (k, backend)
+getBackend :: FilePath -> Key -> Annex (Maybe Backend)
-			Nothing -> do
+getBackend file k = let bname = keyBackendName k in
-				warning $
+	case maybeLookupBackendName bname of
-					"skipping " ++ file ++
+		Just backend -> return $ Just backend
-					" (unknown backend " ++ bname ++ ")"
+		Nothing -> do
-				return Nothing
+			warning $ "skipping " ++ file ++ " (unknown backend " ++ bname ++ ")"
+			return Nothing
 
 {- Looks up the backend that should be used for a file.
  - That can be configured on a per-file basis in the gitattributes file. -}

Build/Configure.hs

@@ -7,6 +7,7 @@ import Control.Applicative
 import System.Environment (getArgs)
 import Control.Monad.IfElse
 import Control.Monad
+import System.IO
 
 import Build.TestConfig
 import Build.Version
@@ -62,7 +63,11 @@ shaTestCases l = map make l
 		key = "sha" ++ show n
 	  	search [] = return Nothing
 		search (c:cmds) = do
+			putStr $ "(" ++ c
+			hFlush stdout
 			sha <- externalSHA c n "/dev/null"
+			putStr $ ":" ++ show sha ++ ")"
+			hFlush stdout
 			if sha == Right knowngood
 				then return $ Just c
 				else search cmds

Build/DistributionUpdate.hs

@@ -1,6 +1,9 @@
 {- Builds distributon info files for each git-annex release in a directory
  - tree, which must itself be part of a git-annex repository. Only files
- - that are present have their info file created. -}
+ - that are present have their info file created.
+ -
+ - Also gpg signs the files.
+ -}
 
 import Common.Annex
 import Types.Distribution
@@ -15,6 +18,10 @@ import Git.Command
 
 import Data.Time.Clock
 
+-- git-annex distribution signing key (for Joey Hess)
+signingKey :: String
+signingKey = "89C809CB"
+
 main = do
 	state <- Annex.new =<< Git.Construct.fromPath =<< getRepoDir
 	Annex.eval state makeinfos
@@ -36,7 +43,7 @@ makeinfos = do
 		v <- lookupFile f
 		case v of
 			Nothing -> noop
-			Just (k, _b) -> whenM (inAnnex k) $ do
+			Just k -> whenM (inAnnex k) $ do
 				liftIO $ putStrLn f
 				let infofile = f ++ ".info"
 				liftIO $ writeFile infofile $ show $ GitAnnexDistribution
@@ -46,7 +53,9 @@ makeinfos = do
 					, distributionReleasedate = now
 					, distributionUrgentUpgrade = Nothing
 					}
-				void $ inRepo $ runBool [Param "add", Param infofile]
+				void $ inRepo $ runBool [Param "add", File infofile]
+				signFile infofile
+				signFile f
 	void $ inRepo $ runBool 
 		[ Param "commit"
 		, Param "-m"
@@ -81,3 +90,14 @@ getRepoDir = do
 
 mkUrl :: FilePath -> FilePath -> String
 mkUrl basedir f = "https://downloads.kitenet.net/" ++ relPathDirToFile basedir f
+				
+signFile :: FilePath -> Annex ()
+signFile f = do
+	void $ liftIO $ boolSystem "gpg"
+		[ Param "-a"
+		, Param $ "--default-key=" ++ signingKey
+		, Param "--sign"
+		, File f
+		]
+	liftIO $ rename (f ++ ".asc") (f ++ ".sig")
+	void $ inRepo $ runBool [Param "add", File (f ++ ".sig")]

Build/make-sdist.sh

@@ -9,11 +9,12 @@ mkdir --parents dist/$sdist_dir
 
 find . \( -name .git -or -name dist -or -name cabal-dev \) -prune \
 	-or -not -name \\*.orig -not -type d -print \
-| perl -ne "print unless length >= 100 - length q{$sdist_dir}" \
+	| perl -ne "print unless length >= 100 - length q{$sdist_dir}" \
-| xargs cp --parents --target-directory dist/$sdist_dir
+	| grep -v ':' \
+	| xargs cp --parents --target-directory dist/$sdist_dir
 
 cd dist
-tar -caf $sdist_dir.tar.gz $sdist_dir
+tar --format=ustar -caf $sdist_dir.tar.gz $sdist_dir
 
 # Check that tarball can be unpacked by cabal.
 # It's picky about tar longlinks etc.

CmdLine/GitAnnex.hs

@@ -1,6 +1,6 @@
 {- git-annex main program
  -
- - Copyright 2010-2013 Joey Hess <joey@kitenet.net>
+ - Copyright 2010-2014 Joey Hess <joey@kitenet.net>
  -
  - Licensed under the GNU GPL version 3 or higher.
  -}
@@ -12,6 +12,8 @@ module CmdLine.GitAnnex where
 import qualified Git.CurrentRepo
 import CmdLine
 import Command
+import Utility.Env
+import Annex.Ssh
 
 import qualified Command.Add
 import qualified Command.Unannex
@@ -47,6 +49,7 @@ import qualified Command.Unlock
 import qualified Command.Lock
 import qualified Command.PreCommit
 import qualified Command.Find
+import qualified Command.FindRef
 import qualified Command.Whereis
 import qualified Command.List
 import qualified Command.Log
@@ -55,6 +58,7 @@ import qualified Command.Info
 import qualified Command.Status
 import qualified Command.Migrate
 import qualified Command.Uninit
+import qualified Command.Reinit
 import qualified Command.NumCopies
 import qualified Command.Trust
 import qualified Command.Untrust
@@ -123,6 +127,7 @@ cmds = concat
 	, Command.Reinject.def
 	, Command.Unannex.def
 	, Command.Uninit.def
+	, Command.Reinit.def
 	, Command.PreCommit.def
 	, Command.NumCopies.def
 	, Command.Trust.def
@@ -154,6 +159,7 @@ cmds = concat
 	, Command.DropUnused.def
 	, Command.AddUnused.def
 	, Command.Find.def
+	, Command.FindRef.def
 	, Command.Whereis.def
 	, Command.List.def
 	, Command.Log.def
@@ -193,4 +199,5 @@ run args = do
 #ifdef WITH_EKG
 	_ <- forkServer "localhost" 4242
 #endif
-	dispatch True args cmds gitAnnexOptions [] header Git.CurrentRepo.get
+	maybe (dispatch True args cmds gitAnnexOptions [] header Git.CurrentRepo.get)
+		(runSshCaching args) =<< getEnv sshCachingEnv

CmdLine/Seek.hs

@@ -19,6 +19,8 @@ import qualified Annex
 import qualified Git
 import qualified Git.Command
 import qualified Git.LsFiles as LsFiles
+import qualified Git.LsTree as LsTree
+import Git.FilePath
 import qualified Limit
 import CmdLine.Option
 import CmdLine.Action
@@ -49,6 +51,20 @@ withFilesNotInGit skipdotfiles a params
 	go l = seekActions $ prepFiltered a $
 		return $ concat $ segmentPaths params l
 
+withFilesInRefs :: (FilePath -> Key -> CommandStart) -> CommandSeek
+withFilesInRefs a = mapM_ go
+  where
+	go r = do	
+		matcher <- Limit.getMatcher
+		l <- inRepo $ LsTree.lsTree (Git.Ref r)
+		forM_ l $ \i -> do
+			let f = getTopFilePath $ LsTree.file i
+			v <- catKey (Git.Ref $ LsTree.sha i) (LsTree.mode i)
+			case v of
+				Nothing -> noop
+				Just k -> whenM (matcher $ MatchingKey k) $
+					void $ commandAction $ a f k
+
 withPathContents :: ((FilePath, FilePath) -> CommandStart) -> CommandSeek
 withPathContents a params = seekActions $ 
 	map a . concat <$> liftIO (mapM get params)

CmdLine/Usage.hs

@@ -93,6 +93,8 @@ paramFormat :: String
 paramFormat = "FORMAT"
 paramFile :: String
 paramFile = "FILE"
+paramRef :: String
+paramRef = "REF"
 paramGroup :: String
 paramGroup = "GROUP"
 paramExpression :: String

Command.hs

@@ -70,11 +70,11 @@ stopUnless :: Annex Bool -> Annex (Maybe a) -> Annex (Maybe a)
 stopUnless c a = ifM c ( a , stop )
 
 {- Modifies an action to only act on files that are already annexed,
- - and passes the key and backend on to it. -}
+ - and passes the key on to it. -}
-whenAnnexed :: (FilePath -> (Key, Backend) -> Annex (Maybe a)) -> FilePath -> Annex (Maybe a)
+whenAnnexed :: (FilePath -> Key -> Annex (Maybe a)) -> FilePath -> Annex (Maybe a)
 whenAnnexed a file = ifAnnexed file (a file) (return Nothing)
 
-ifAnnexed :: FilePath -> ((Key, Backend) -> Annex a) -> Annex a -> Annex a
+ifAnnexed :: FilePath -> (Key -> Annex a) -> Annex a -> Annex a
 ifAnnexed file yes no = maybe no yes =<< Backend.lookupFile file
 
 isBareRepo :: Annex Bool

Command/Add.hs

@@ -73,7 +73,7 @@ start file = ifAnnexed file addpresent add
 				| otherwise -> do
 					showStart "add" file
 					next $ perform file
-	addpresent (key, _) = ifM isDirect
+	addpresent key = ifM isDirect
 		( ifM (goodContent key file) ( stop , add )
 		, fixup key
 		)

Command/AddUrl.hs

@@ -96,7 +96,7 @@ performQuvi :: Bool -> URLString -> URLString -> FilePath -> CommandPerform
 performQuvi relaxed pageurl videourl file = ifAnnexed file addurl geturl
   where
   	quviurl = setDownloader pageurl QuviDownloader
-  	addurl (key, _backend) = next $ cleanup quviurl file key Nothing
+  	addurl key = next $ cleanup quviurl file key Nothing
 	geturl = next $ addUrlFileQuvi relaxed quviurl videourl file
 #endif
 
@@ -130,7 +130,7 @@ perform :: Bool -> URLString -> FilePath -> CommandPerform
 perform relaxed url file = ifAnnexed file addurl geturl
   where
 	geturl = next $ addUrlFile relaxed url file
-	addurl (key, _backend)
+	addurl key
 		| relaxed = do
 			setUrlPresent key url
 			next $ return True

Command/Copy.hs

@@ -30,9 +30,9 @@ seek ps = do
 {- A copy is just a move that does not delete the source file.
  - However, --auto mode avoids unnecessary copies, and avoids getting or
  - sending non-preferred content. -}
-start :: Maybe Remote -> Maybe Remote -> FilePath -> (Key, Backend) -> CommandStart
+start :: Maybe Remote -> Maybe Remote -> FilePath -> Key -> CommandStart
-start to from file (key, backend) = stopUnless shouldCopy $ 
+start to from file key = stopUnless shouldCopy $ 
-	Command.Move.start to from False file (key, backend)
+	Command.Move.start to from False file key
   where
 	shouldCopy = checkAuto (check <||> numCopiesCheck file key (<))
 	check = case to of

Command/Direct.hs

@@ -47,7 +47,7 @@ perform = do
 	void $ liftIO clean
 	next cleanup
   where
-	go = whenAnnexed $ \f (k, _) -> do
+	go = whenAnnexed $ \f k -> do
 		r <- toDirectGen k f
 		case r of
 			Nothing -> noop

Command/Drop.hs

@@ -34,8 +34,8 @@ seek ps = do
 	from <- getOptionField dropFromOption Remote.byNameWithUUID
 	withFilesInGit (whenAnnexed $ start from) ps
 
-start :: Maybe Remote -> FilePath -> (Key, Backend) -> CommandStart
+start :: Maybe Remote -> FilePath -> Key -> CommandStart
-start from file (key, _) = checkDropAuto from file key $ \numcopies ->
+start from file key = checkDropAuto from file key $ \numcopies ->
 	stopUnless (checkAuto $ wantDrop False (Remote.uuid <$> from) (Just key) (Just file)) $
 		case from of
 			Nothing -> startLocal (Just file) numcopies key Nothing
@@ -78,12 +78,18 @@ performRemote :: Key -> AssociatedFile -> NumCopies -> Remote -> CommandPerform
 performRemote key afile numcopies remote = lockContent key $ do
 	-- Filter the remote it's being dropped from out of the lists of
 	-- places assumed to have the key, and places to check.
-	-- When the local repo has the key, that's one additional copy.
+	-- When the local repo has the key, that's one additional copy,
+	-- as long asthe local repo is not untrusted.
 	(remotes, trusteduuids) <- Remote.keyPossibilitiesTrusted key
 	present <- inAnnex key
 	u <- getUUID
-	let have = filter (/= uuid) $
+	trusteduuids' <- if present
-		if present then u:trusteduuids else trusteduuids
+		then ifM ((<= SemiTrusted) <$> lookupTrust u)
+			( pure (u:trusteduuids)
+			, pure trusteduuids
+			)
+		else pure trusteduuids
+	let have = filter (/= uuid) trusteduuids'
 	untrusteduuids <- trustGet UnTrusted
 	let tocheck = filter (/= remote) $
 		Remote.remotesWithoutUUID remotes (have++untrusteduuids)

Command/Find.hs

@@ -19,8 +19,10 @@ import Utility.DataUnits
 import Types.Key
 
 def :: [Command]
-def = [noCommit $ noMessages $ withOptions [formatOption, print0Option, jsonOption] $
+def = [mkCommand $ command "find" paramPaths seek SectionQuery "lists available files"]
-	command "find" paramPaths seek SectionQuery "lists available files"]
+
+mkCommand :: Command -> Command
+mkCommand = noCommit . noMessages . withOptions [formatOption, print0Option, jsonOption]
 
 formatOption :: Option
 formatOption = fieldOption [] "format" paramFormat "control format of output"
@@ -39,8 +41,8 @@ seek ps = do
 	format <- getFormat
 	withFilesInGit (whenAnnexed $ start format) ps
 
-start :: Maybe Utility.Format.Format -> FilePath -> (Key, Backend) -> CommandStart
+start :: Maybe Utility.Format.Format -> FilePath -> Key -> CommandStart
-start format file (key, _) = do
+start format file key = do
 	-- only files inAnnex are shown, unless the user has requested
 	-- others via a limit
 	whenM (limited <||> inAnnex key) $

Command/FindRef.hs

@@ -0,0 +1,20 @@
+{- git-annex command
+ -
+ - Copyright 2014 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.FindRef where
+
+import Command
+import qualified Command.Find as Find
+
+def :: [Command]
+def = [Find.mkCommand $ command "findref" paramRef seek SectionPlumbing
+	"lists files in a git ref"]
+
+seek :: CommandSeek
+seek refs = do
+	format <- Find.getFormat
+	Find.start format `withFilesInRefs` refs

Command/Fix.hs

@@ -26,8 +26,8 @@ seek :: CommandSeek
 seek = withFilesInGit $ whenAnnexed start
 
 {- Fixes the symlink to an annexed file. -}
-start :: FilePath -> (Key, Backend) -> CommandStart
+start :: FilePath -> Key -> CommandStart
-start file (key, _) = do
+start file key = do
 	link <- inRepo $ gitAnnexLink file key
 	stopUnless ((/=) (Just link) <$> liftIO (catchMaybeIO $ readSymbolicLink file)) $ do
 		showStart "fix" file

Command/Fsck.hs

@@ -104,12 +104,16 @@ getIncremental = do
 						resetStartTime
 		return True
 
-start :: Maybe Remote -> Incremental -> FilePath -> (Key, Backend) -> CommandStart
+start :: Maybe Remote -> Incremental -> FilePath -> Key -> CommandStart
-start from inc file (key, backend) = do
+start from inc file key = do
-	numcopies <- getFileNumCopies file
+	v <- Backend.getBackend file key
-	case from of
+	case v of
-		Nothing -> go $ perform key file backend numcopies
+		Nothing -> stop
-		Just r -> go $ performRemote key file backend numcopies r
+		Just backend -> do
+			numcopies <- getFileNumCopies file
+			case from of
+				Nothing -> go $ perform key file backend numcopies
+				Just r -> go $ performRemote key file backend numcopies r
   where
 	go = runFsck inc file key
 

Command/Get.hs

@@ -31,8 +31,8 @@ seek ps = do
 		(withFilesInGit $ whenAnnexed $ start from)
 		ps
 
-start :: Maybe Remote -> FilePath -> (Key, Backend) -> CommandStart
+start :: Maybe Remote -> FilePath -> Key -> CommandStart
-start from file (key, _) = start' expensivecheck from key (Just file)
+start from file key = start' expensivecheck from key (Just file)
   where
 	expensivecheck = checkAuto (numCopiesCheck file key (<) <||> wantGet False (Just key) (Just file))
 

Command/ImportFeed.hs

@@ -194,7 +194,7 @@ performDownload relaxed cache todownload = case location todownload of
 				in d </> show n ++ "_" ++ base
 		tryanother = makeunique url (n + 1) file
 		alreadyexists = liftIO $ isJust <$> catchMaybeIO (getSymbolicLinkStatus f)
-		checksameurl (k, _) = ifM (elem url <$> getUrls k)
+		checksameurl k = ifM (elem url <$> getUrls k)
 			( return Nothing
 			, tryanother
 			)

Command/Indirect.hs

@@ -74,7 +74,7 @@ perform = do
 		case r of
 			Just s
 				| isSymbolicLink s -> void $ flip whenAnnexed f $
-					\_ (k, _) -> do
+					\_ k -> do
 						removeInodeCache k
 						removeAssociatedFiles k
 						return Nothing

Command/Info.hs

@@ -70,7 +70,7 @@ data StatInfo = StatInfo
 type StatState = StateT StatInfo Annex
 
 def :: [Command]
-def = [noCommit $ withOptions [jsonOption] $
+def = [noCommit $ dontCheck repoExists $ withOptions [jsonOption] $
 	command "info" paramPaths seek SectionQuery
 	"shows general information about the annex"]
 

Command/List.hs

@@ -60,8 +60,8 @@ getList = ifM (Annex.getFlag $ optionName allrepos)
 printHeader :: [(UUID, RemoteName, TrustLevel)] -> Annex ()
 printHeader l = liftIO $ putStrLn $ header $ map (\(_, n, t) -> (n, t)) l
 
-start :: [(UUID, RemoteName, TrustLevel)] -> FilePath -> (Key, Backend) -> CommandStart
+start :: [(UUID, RemoteName, TrustLevel)] -> FilePath -> Key -> CommandStart
-start l file (key, _) = do
+start l file key = do
 	ls <- S.fromList <$> keyLocations key
 	liftIO $ putStrLn $ format (map (\(u, _, t) -> (t, S.member u ls)) l) file
 	stop

Command/Log.hs

@@ -64,9 +64,15 @@ seek ps = do
 		Annex.getField (optionName o)
 	use o v = [Param ("--" ++ optionName o), Param v]
 
-start :: M.Map UUID String -> TimeZone -> [CommandParam] -> Bool ->
+start
-	FilePath -> (Key, Backend) -> CommandStart
+	:: M.Map UUID String
-start m zone os gource file (key, _) = do
+	-> TimeZone
+	-> [CommandParam]
+	-> Bool
+	-> FilePath
+	-> Key
+	-> CommandStart
+start m zone os gource file key = do
 	showLog output =<< readLog <$> getLog key os
 	-- getLog produces a zombie; reap it
 	liftIO reapZombies

Command/MetaData.hs

@@ -63,8 +63,8 @@ seek ps = do
 		(withFilesInGit (whenAnnexed $ start now getfield modmeta))
 		ps
 
-start :: POSIXTime -> Maybe MetaField -> [ModMeta] -> FilePath -> (Key, Backend) -> CommandStart
+start :: POSIXTime -> Maybe MetaField -> [ModMeta] -> FilePath -> Key -> CommandStart
-start now f ms file (k, _) = start' (Just file) now f ms k
+start now f ms file = start' (Just file) now f ms
 
 startKeys :: POSIXTime -> Maybe MetaField -> [ModMeta] -> Key -> CommandStart
 startKeys = start' Nothing

Command/Migrate.hs

@@ -25,15 +25,19 @@ def = [notDirect $
 seek :: CommandSeek
 seek = withFilesInGit $ whenAnnexed start
 
-start :: FilePath -> (Key, Backend) -> CommandStart
+start :: FilePath -> Key -> CommandStart
-start file (key, oldbackend) = do
+start file key = do
-	exists <- inAnnex key
+	v <- Backend.getBackend file key
-	newbackend <- choosebackend =<< chooseBackend file
+	case v of
-	if (newbackend /= oldbackend || upgradableKey oldbackend key) && exists
+		Nothing -> stop
-		then do
+		Just oldbackend -> do
-			showStart "migrate" file
+			exists <- inAnnex key
-			next $ perform file key oldbackend newbackend
+			newbackend <- choosebackend =<< chooseBackend file
-		else stop
+			if (newbackend /= oldbackend || upgradableKey oldbackend key) && exists
+				then do
+					showStart "migrate" file
+					next $ perform file key oldbackend newbackend
+				else stop
   where
 	choosebackend Nothing = Prelude.head <$> orderedList
 	choosebackend (Just backend) = return backend

Command/Mirror.hs

@@ -31,8 +31,8 @@ seek ps = do
 		(withFilesInGit $ whenAnnexed $ start to from)
 		ps
 
-start :: Maybe Remote -> Maybe Remote -> FilePath -> (Key, Backend) -> CommandStart
+start :: Maybe Remote -> Maybe Remote -> FilePath -> Key -> CommandStart
-start to from file (key, _backend) = startKey to from (Just file) key
+start to from file key = startKey to from (Just file) key
 
 startKey :: Maybe Remote -> Maybe Remote -> Maybe FilePath -> Key -> CommandStart
 startKey to from afile key = do

Command/Move.hs

@@ -33,8 +33,8 @@ seek ps = do
 		(withFilesInGit $ whenAnnexed $ start to from True)
 		ps
 
-start :: Maybe Remote -> Maybe Remote -> Bool -> FilePath -> (Key, Backend) -> CommandStart
+start :: Maybe Remote -> Maybe Remote -> Bool -> FilePath -> Key -> CommandStart
-start to from move file (key, _) = start' to from move (Just file) key
+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 = start' to from move Nothing

Command/ReKey.hs

@@ -29,7 +29,7 @@ start :: (FilePath, String) -> CommandStart
 start (file, keyname) = ifAnnexed file go stop
   where
 	newkey = fromMaybe (error "bad key") $ file2key keyname
-	go (oldkey, _)
+	go oldkey
 		| oldkey == newkey = stop
 		| otherwise = do
 			showStart "rekey" file

Command/Reinit.hs

@@ -0,0 +1,38 @@
+{- git-annex command
+ -
+ - Copyright 2014 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.Reinit where
+
+import Common.Annex
+import Command
+import Annex.Init
+import Annex.UUID
+import Types.UUID
+import qualified Remote
+	
+def :: [Command]
+def = [dontCheck repoExists $
+	command "reinit" (paramUUID ++ " or " ++ paramDesc) seek SectionUtility ""]
+
+seek :: CommandSeek
+seek = withWords start
+
+start :: [String] -> CommandStart
+start ws = do
+	showStart "reinit" s
+	next $ perform s
+  where
+	s = unwords ws
+
+perform :: String -> CommandPerform
+perform s = do
+	u <- if isUUID s
+		then return $ toUUID s
+		else Remote.nameToUUID s
+	storeUUID u
+	initialize'
+	next $ return True

Command/Reinject.hs

@@ -12,6 +12,7 @@ import Command
 import Logs.Location
 import Annex.Content
 import qualified Command.Fsck
+import qualified Backend
 
 def :: [Command]
 def = [command "reinject" (paramPair "SRC" "DEST") seek
@@ -33,16 +34,20 @@ start (src:dest:[])
 		next $ whenAnnexed (perform src) dest
 start _ = error "specify a src file and a dest file"
 
-perform :: FilePath -> FilePath -> (Key, Backend) -> CommandPerform
+perform :: FilePath -> FilePath -> Key -> CommandPerform
-perform src _dest (key, backend) =
+perform src dest key = do
 	{- Check the content before accepting it. -}
-	ifM (Command.Fsck.checkKeySizeOr reject key src
+	v <- Backend.getBackend dest key
-		<&&> Command.Fsck.checkBackendOr reject backend key src)
+	case v of
-		( do
+		Nothing -> stop
-			unlessM move $ error "mv failed!"
+		Just backend ->
-			next $ cleanup key
+			ifM (Command.Fsck.checkKeySizeOr reject key src
-		, error "not reinjecting"
+				<&&> Command.Fsck.checkBackendOr reject backend key src)
-		)
+				( do
+					unlessM move $ error "mv failed!"
+					next $ cleanup key
+				, error "not reinjecting"
+				)
   where
 	-- the file might be on a different filesystem,
 	-- so mv is used rather than simply calling

Command/RmUrl.hs

@@ -20,7 +20,7 @@ seek :: CommandSeek
 seek = withPairs start
 
 start :: (FilePath, String) -> CommandStart
-start (file, url) = flip whenAnnexed file $ \_ (key, _) -> do
+start (file, url) = flip whenAnnexed file $ \_ key -> do
 	showStart "rmurl" file
 	next $ next $ cleanup url key
 

Command/Sync.hs

@@ -21,7 +21,6 @@ import qualified Git.LsFiles as LsFiles
 import qualified Git.Branch
 import qualified Git.Ref
 import qualified Git
-import qualified Types.Remote
 import qualified Remote.Git
 import Config
 import Annex.Wanted
@@ -32,6 +31,7 @@ import Logs.Location
 import Annex.Drop
 import Annex.UUID
 import Annex.AutoMerge
+import Annex.Ssh
 
 import Control.Concurrent.MVar
 
@@ -113,11 +113,11 @@ syncRemotes rs = ifM (Annex.getState Annex.fast) ( nub <$> pickfast , wanted )
 		| null rs = filterM good =<< concat . Remote.byCost <$> available
 		| otherwise = listed
 	listed = catMaybes <$> mapM (Remote.byName . Just) rs
-	available = filter (remoteAnnexSync . Types.Remote.gitconfig)
+	available = filter (remoteAnnexSync . Remote.gitconfig)
 		. filter (not . Remote.isXMPPRemote)
 		<$> Remote.remoteList
 	good r
-		| Remote.gitSyncableRemote r = Remote.Git.repoAvail $ Types.Remote.repo r
+		| Remote.gitSyncableRemote r = Remote.Git.repoAvail $ Remote.repo r
 		| otherwise = return True
 	fastest = fromMaybe [] . headMaybe . Remote.byCost
 
@@ -201,7 +201,7 @@ pullRemote remote branch = do
 		stopUnless fetch $
 			next $ mergeRemote remote branch
   where
-	fetch = inRepo $ Git.Command.runBool
+	fetch = inRepoWithSshCachingTo (Remote.repo remote) $ Git.Command.runBool
 		[Param "fetch", Param $ Remote.name remote]
 
 {- The remote probably has both a master and a synced/master branch.
@@ -227,14 +227,15 @@ pushRemote _remote Nothing = stop
 pushRemote remote (Just branch) = go =<< needpush
   where
 	needpush
-		| remoteAnnexReadOnly (Types.Remote.gitconfig remote) = return False
+		| remoteAnnexReadOnly (Remote.gitconfig remote) = return False
 		| otherwise = anyM (newer remote) [syncBranch branch, Annex.Branch.name]
 	go False = stop
 	go True = do
 		showStart "push" (Remote.name remote)
 		next $ next $ do
 			showOutput
-			ok <- inRepo $ pushBranch remote branch
+			ok <- inRepoWithSshCachingTo (Remote.repo remote) $
+				pushBranch remote branch
 			unless ok $ do
 				warning $ unwords [ "Pushing to " ++ Remote.name remote ++ " failed." ]
 				showLongNote "(non-fast-forward problems can be solved by setting receive.denyNonFastforwards to false in the remote's git config)"
@@ -337,8 +338,8 @@ seekSyncContent rs = do
 		(\v -> void (liftIO (tryPutMVar mvar ())) >> syncFile rs f v)
 		noop
 
-syncFile :: [Remote] -> FilePath -> (Key, Backend) -> Annex ()
+syncFile :: [Remote] -> FilePath -> Key -> Annex ()
-syncFile rs f (k, _) = do
+syncFile rs f k = do
 	locs <- loggedLocations k
 	let (have, lack) = partition (\r -> Remote.uuid r `elem` locs) rs
 
@@ -367,7 +368,7 @@ syncFile rs f (k, _) = do
 		next $ next $ getViaTmp k $ \dest -> getKeyFile' k (Just f) dest have
 
 	wantput r
-		| Remote.readonly r || remoteAnnexReadOnly (Types.Remote.gitconfig r) = return False
+		| Remote.readonly r || remoteAnnexReadOnly (Remote.gitconfig r) = return False
 		| otherwise = wantSend True (Just k) (Just f) (Remote.uuid r)
 	handleput lack = ifM (inAnnex k)
 		( map put <$> filterM wantput lack

Command/Unannex.hs

@@ -58,8 +58,8 @@ wrapUnannex a = ifM isDirect
 			then void (liftIO cleanup) >> return True
 			else void (liftIO cleanup) >> return False
 
-start :: FilePath -> (Key, Backend) -> CommandStart
+start :: FilePath -> Key -> CommandStart
-start file (key, _) = stopUnless (inAnnex key) $ do
+start file key = stopUnless (inAnnex key) $ do
 	showStart "unannex" file
 	next $ ifM isDirect
 		( performDirect file key
@@ -75,7 +75,16 @@ cleanupIndirect :: FilePath -> Key -> CommandCleanup
 cleanupIndirect file key = do
 	src <- calcRepo $ gitAnnexLocation key
 	ifM (Annex.getState Annex.fast)
-		( hardlinkfrom src
+		( do
+			-- Only make a hard link if the annexed file does not
+			-- already have other hard links pointing at it.
+			-- This avoids unannexing (and uninit) ending up
+			-- hard linking files together, which would be
+			-- surprising.
+			s <- liftIO $ getFileStatus src
+			if linkCount s > 1
+				then copyfrom src
+				else hardlinkfrom src
 		, copyfrom src
 		)
   where

Command/Uninit.hs

@@ -8,6 +8,7 @@
 module Command.Uninit where
 
 import Common.Annex
+import qualified Annex
 import Command
 import qualified Git
 import qualified Git.Command
@@ -37,12 +38,13 @@ check = do
 seek :: CommandSeek
 seek ps = do
 	withFilesNotInGit False (whenAnnexed startCheckIncomplete) ps
+	Annex.changeState $ \s -> s { Annex.fast = True }
 	withFilesInGit (whenAnnexed Command.Unannex.start) ps
 	finish
 
 {- git annex symlinks that are not checked into git could be left by an
  - interrupted add. -}
-startCheckIncomplete :: FilePath -> (Key, Backend) -> CommandStart
+startCheckIncomplete :: FilePath -> Key -> CommandStart
 startCheckIncomplete file _ = error $ unlines
 	[ file ++ " points to annexed content, but is not checked into git."
 	, "Perhaps this was left behind by an interrupted git annex add?"

Command/Unlock.hs

@@ -25,8 +25,8 @@ seek = withFilesInGit $ whenAnnexed start
 
 {- The unlock subcommand replaces the symlink with a copy of the file's
  - content. -}
-start :: FilePath -> (Key, Backend) -> CommandStart
+start :: FilePath -> Key -> CommandStart
-start file (key, _) = do
+start file key = do
 	showStart "unlock" file
 	next $ perform file key
 

Command/Unused.hs

@@ -250,7 +250,7 @@ withKeysReferenced' mdir initial a = do
 		x <- Backend.lookupFile f
 		case x of
 			Nothing -> go v fs
-			Just (k, _) -> do
+			Just k -> do
 				!v' <- a k f v
 				go v' fs
 
@@ -294,7 +294,7 @@ withKeysReferencedInGitRef a ref = do
 	forM_ ts $ tKey lookAtWorkingTree >=> maybe noop a
 	liftIO $ void clean
   where
-	tKey True = fmap fst <$$> Backend.lookupFile . getTopFilePath . DiffTree.file
+	tKey True = Backend.lookupFile . getTopFilePath . DiffTree.file
 	tKey False = fileKey . takeFileName . decodeBS <$$>
 		catFile ref . getTopFilePath . DiffTree.file
 

Command/WebApp.hs

@@ -65,7 +65,7 @@ start' allowauto listenhost = do
 	stop
   where
 	go = do
-		cannotrun <- needsUpgrade . fromMaybe (error "no version") =<< getVersion
+		cannotrun <- needsUpgrade . fromMaybe (error "annex.version is not set.. seems this repository has not been initialized by git-annex") =<< getVersion
 		browser <- fromRepo webBrowser
 		f <- liftIO . absPath =<< fromRepo gitAnnexHtmlShim
 		listenhost' <- if isJust listenhost
@@ -98,7 +98,7 @@ start' allowauto listenhost = do
 	checkshim f = liftIO $ doesFileExist f
 
 {- When run without a repo, start the first available listed repository in
- - the autostart file. If not, it's our first time being run! -}
+ - the autostart file. If none, it's our first time being run! -}
 startNoRepo :: CmdParams -> IO ()
 startNoRepo _ = do
 	-- FIXME should be able to reuse regular getopt, but 
@@ -107,13 +107,18 @@ startNoRepo _ = do
 	let listenhost = headMaybe $ map (snd . separate (== '=')) $ 
 		filter ("--listen=" `isPrefixOf`) args
 
-	dirs <- liftIO $ filterM doesDirectoryExist =<< readAutoStartFile
+	go listenhost =<< liftIO (filterM doesDirectoryExist =<< readAutoStartFile)
-	case dirs of
+  where
-		[] -> firstRun listenhost
+	go listenhost [] = firstRun listenhost
-		(d:_) -> do
+	go listenhost (d:ds) = do
+		v <- tryNonAsync $ do
 			setCurrentDirectory d
-			state <- Annex.new =<< Git.CurrentRepo.get
+			Annex.new =<< Git.CurrentRepo.get
-			void $ Annex.eval state $ do
+		case v of
+			Left e -> do
+				warningIO $ "unable to start webapp in " ++ d ++ ": " ++ show e
+				go listenhost ds
+			Right state -> void $ Annex.eval state $ do
 				whenM (fromRepo Git.repoIsLocalBare) $
 					error $ d ++ " is a bare git repository, cannot run the webapp in it"
 				callCommandAction $

Command/Whereis.hs

@@ -27,8 +27,8 @@ seek ps = do
 		(withFilesInGit $ whenAnnexed $ start m)
 		ps
 
-start :: M.Map UUID Remote -> FilePath -> (Key, Backend) -> CommandStart
+start :: M.Map UUID Remote -> FilePath -> Key -> CommandStart
-start remotemap file (key, _) = start' remotemap key (Just file)
+start remotemap file key = start' remotemap key (Just file)
 
 startKeys :: M.Map UUID Remote -> Key -> CommandStart
 startKeys remotemap key = start' remotemap key Nothing

Creds.hs

@@ -14,6 +14,7 @@ module Creds (
 	getEnvCredPair,
 	writeCacheCreds,
 	readCacheCreds,
+	removeCreds,
 ) where
 
 import Common.Annex
@@ -138,3 +139,9 @@ decodeCredPair :: Creds -> Maybe CredPair
 decodeCredPair creds = case lines creds of
 	l:p:[] -> Just (l, p)
 	_ -> Nothing
+
+removeCreds :: FilePath -> Annex ()
+removeCreds file = do
+	d <- fromRepo gitAnnexCredsDir
+	let f = d </> file
+	liftIO $ nukeFile f

Git/GCrypt.hs

@@ -16,8 +16,11 @@ import qualified Git.Config as Config
 import qualified Git.Command as Command
 import Utility.Gpg
 
+urlScheme :: String
+urlScheme = "gcrypt:"
+
 urlPrefix :: String
-urlPrefix = "gcrypt::"
+urlPrefix = urlScheme ++ ":"
 
 isEncrypted :: Repo -> Bool
 isEncrypted Repo { location = Url url } = urlPrefix `isPrefixOf` show url

Limit.hs

@@ -234,10 +234,10 @@ limitSize vs s = case readSize dataUnits s of
 	Nothing -> Left "bad size"
 	Just sz -> Right $ go sz
   where
-  	go sz _ (MatchingFile fi) = lookupFile fi >>= check fi sz
+  	go sz _ (MatchingFile fi) = lookupFileKey fi >>= check fi sz
 	go sz _ (MatchingKey key) = checkkey sz key
 	checkkey sz key = return $ keySize key `vs` Just sz
-	check _ sz (Just (key, _)) = checkkey sz key
+	check _ sz (Just key) = checkkey sz key
 	check fi sz Nothing = do
 		filesize <- liftIO $ catchMaybeIO $
 			fromIntegral . fileSize
@@ -272,11 +272,8 @@ addTimeLimit s = do
 				liftIO $ exitWith $ ExitFailure 101
 			else return True
 
-lookupFile :: FileInfo -> Annex (Maybe (Key, Backend))
-lookupFile = Backend.lookupFile . relFile
-
 lookupFileKey :: FileInfo -> Annex (Maybe Key)
-lookupFileKey = (fst <$>) <$$> Backend.lookupFile . relFile
+lookupFileKey = Backend.lookupFile . relFile
 
 checkKey :: (Key -> Annex Bool) -> MatchInfo -> Annex Bool
 checkKey a (MatchingFile fi) = lookupFileKey fi >>= maybe (return False) a

Makefile

@@ -253,7 +253,7 @@ hdevtools:
 distributionupdate:
 	git pull
 	cabal configure
-	ghc --make Build/DistributionUpdate -XPackageImports
+	ghc --make Build/DistributionUpdate -XPackageImports -optP-include -optPdist/build/autogen/cabal_macros.h
 	./Build/DistributionUpdate
 
 .PHONY: git-annex git-union-merge git-recover-repository tags build-stamp

Remote.hs

@@ -22,6 +22,7 @@ module Remote (
 	remoteList,
 	gitSyncableRemote,
 	remoteMap,
+	remoteMap',
 	uuidDescriptions,
 	byName,
 	byNameOnly,
@@ -64,9 +65,19 @@ import Git.Types (RemoteName)
 import qualified Git
 
 {- Map from UUIDs of Remotes to a calculated value. -}
-remoteMap :: (Remote -> a) -> Annex (M.Map UUID a)
+remoteMap :: (Remote -> v) -> Annex (M.Map UUID v)
-remoteMap c = M.fromList . map (\r -> (uuid r, c r)) .
+remoteMap mkv = remoteMap' mkv mkk
-	filter (\r -> uuid r /= NoUUID) <$> remoteList
+  where
+	mkk r = case uuid r of
+		NoUUID -> Nothing
+		u -> Just u
+
+remoteMap' :: Ord k => (Remote -> v) -> (Remote -> Maybe k) -> Annex (M.Map k v)
+remoteMap' mkv mkk = M.fromList . mapMaybe mk <$> remoteList
+  where
+	mk r = case mkk r of
+		Nothing -> Nothing
+		Just k -> Just (k, mkv r)
 
 {- Map of UUIDs of remotes and their descriptions.
  - The names of Remotes are added to suppliment any description that has

Remote/Git.hs

@@ -312,7 +312,7 @@ copyFromRemote r key file dest _p = copyFromRemote' r key file dest
 copyFromRemote' :: Remote -> Key -> AssociatedFile -> FilePath -> Annex Bool
 copyFromRemote' r key file dest
 	| not $ Git.repoIsUrl (repo r) = guardUsable (repo r) False $ do
-		let params = Ssh.rsyncParams r Download
+		params <- Ssh.rsyncParams r Download
 		u <- getUUID
 		-- run copy from perspective of remote
 		onLocal r $ do
@@ -411,7 +411,7 @@ copyToRemote r key file p
 		-- the remote's Annex, but it needs access to the current
 		-- Annex monad's state.
 		checksuccessio <- Annex.withCurrentState checksuccess
-		let params = Ssh.rsyncParams r Upload
+		params <- Ssh.rsyncParams r Upload
 		u <- getUUID
 		-- run copy from perspective of remote
 		onLocal r $ ifM (Annex.Content.inAnnex key)

Remote/Helper/Ssh.hs

@@ -21,6 +21,7 @@ import Utility.Metered
 import Utility.Rsync
 import Types.Remote
 import Logs.Transfer
+import Config
 
 {- Generates parameters to ssh to a repository's host and run a command.
  - Caller is responsible for doing any neccessary shellEscaping of the
@@ -122,7 +123,7 @@ rsyncParamsRemote direct r direction key file afile = do
 		fields
 	-- Convert the ssh command into rsync command line.
 	let eparam = rsyncShell (Param shellcmd:shellparams)
-	let o = rsyncParams r direction
+	o <- rsyncParams r direction
 	return $ if direction == Download
 		then o ++ rsyncopts eparam dummy (File file)
 		else o ++ rsyncopts eparam (File file) dummy
@@ -140,9 +141,19 @@ rsyncParamsRemote direct r direction key file afile = do
 	dummy = Param "dummy:"
 
 -- --inplace to resume partial files
-rsyncParams :: Remote -> Direction -> [CommandParam]
+--
-rsyncParams r direction = Params "--progress --inplace" :
+-- Only use --perms when not on a crippled file system, as rsync
-	map Param (remoteAnnexRsyncOptions gc ++ dps)
+-- will fail trying to restore file perms onto a filesystem that does not
+-- support them.
+rsyncParams :: Remote -> Direction -> Annex [CommandParam]
+rsyncParams r direction = do
+	crippled <- crippledFileSystem
+	return $ map Param $ catMaybes
+		[ Just "--progress"
+		, Just "--inplace"
+		, if crippled then Nothing else Just "--perms"
+		] 
+		++ remoteAnnexRsyncOptions gc ++ dps
   where
 	dps
 		| direction == Download = remoteAnnexRsyncDownloadOptions gc

RemoteDaemon/Common.hs

@@ -20,7 +20,7 @@ import Annex.CatFile
 import Control.Concurrent
 
 -- Runs an Annex action. Long-running actions should be avoided,
--- since only one liftAnnex can be running at a time, amoung all
+-- since only one liftAnnex can be running at a time, across all
 -- transports.
 liftAnnex :: TransportHandle -> Annex a -> IO a
 liftAnnex (TransportHandle _ annexstate) a = do

RemoteDaemon/Core.hs

@@ -18,6 +18,7 @@ import qualified Git.Types as Git
 import qualified Git.CurrentRepo
 import Utility.SimpleProtocol
 import Config
+import Annex.Ssh
 
 import Control.Concurrent.Async
 import Control.Concurrent
@@ -60,17 +61,24 @@ runController ichan ochan = do
 		cmd <- readChan ichan
 		case cmd of
 			RELOAD -> do
-				liftAnnex h reloadConfig
+				h' <- updateTransportHandle h
-				m' <- genRemoteMap h ochan
+				m' <- genRemoteMap h' ochan
 				let common = M.intersection m m'
 				let new = M.difference m' m
 				let old = M.difference m m'
-				stoprunning old
+				broadcast STOP old
 				unless paused $
 					startrunning new
-				go h paused (M.union common new)
+				go h' paused (M.union common new)
+			LOSTNET -> do
+				-- force close all cached ssh connections
+				-- (done here so that if there are multiple
+				-- ssh remotes, it's only done once)
+				liftAnnex h forceSshCleanup
+				broadcast LOSTNET m
+				go h True m
 			PAUSE -> do
-				stoprunning m
+				broadcast STOP m
 				go h True m
 			RESUME -> do
 				when paused $
@@ -89,14 +97,14 @@ runController ichan ochan = do
 	startrunning m = forM_ (M.elems m) startrunning'
 	startrunning' (transport, _) = void $ async transport
 	
-	-- Ask the transport nicely to stop.
+	broadcast msg m = forM_ (M.elems m) send
-	stoprunning m = forM_ (M.elems m) stoprunning'
+	  where
-	stoprunning' (_, c) = writeChan c STOP
+		send (_, c) = writeChan c msg
 
 -- Generates a map with a transport for each supported remote in the git repo,
 -- except those that have annex.sync = false
 genRemoteMap :: TransportHandle -> Chan Emitted -> IO RemoteMap
-genRemoteMap h@(TransportHandle g _) ochan =
+genRemoteMap h@(TransportHandle g _) ochan = 
 	M.fromList . catMaybes <$> mapM gen (Git.remotes g)
   where
 	gen r = case Git.location r of
@@ -106,7 +114,7 @@ genRemoteMap h@(TransportHandle g _) ochan =
 					ichan <- newChan :: IO (Chan Consumed)
 					return $ Just
 						( r
-						, (transport r (Git.repoDescribe r) h ichan ochan, ichan)
+						, (transport r (RemoteURI u) h ichan ochan, ichan)
 						)
 			_ -> return Nothing
 		_ -> return Nothing
@@ -116,3 +124,10 @@ genTransportHandle = do
 	annexstate <- newMVar =<< Annex.new =<< Git.CurrentRepo.get
 	g <- Annex.repo <$> readMVar annexstate
 	return $ TransportHandle g annexstate
+
+updateTransportHandle :: TransportHandle -> IO TransportHandle
+updateTransportHandle h@(TransportHandle _g annexstate) = do
+	g' <- liftAnnex h $ do
+		reloadConfig
+		Annex.fromRepo id
+	return (TransportHandle g' annexstate)

RemoteDaemon/Transport.hs

@@ -9,6 +9,7 @@ module RemoteDaemon.Transport where
 
 import RemoteDaemon.Types
 import qualified RemoteDaemon.Transport.Ssh
+import qualified Git.GCrypt
 
 import qualified Data.Map as M
 
@@ -18,4 +19,5 @@ type TransportScheme = String
 remoteTransports :: M.Map TransportScheme Transport
 remoteTransports = M.fromList
 	[ ("ssh:", RemoteDaemon.Transport.Ssh.transport)
+	, (Git.GCrypt.urlScheme, RemoteDaemon.Transport.Ssh.transport)
 	]

RemoteDaemon/Transport/Ssh.hs

@@ -8,65 +8,117 @@
 module RemoteDaemon.Transport.Ssh (transport) where
 
 import Common.Annex
+import Annex.Ssh
 import RemoteDaemon.Types
 import RemoteDaemon.Common
 import Remote.Helper.Ssh
 import qualified RemoteDaemon.Transport.Ssh.Types as SshRemote
 import Utility.SimpleProtocol
+import qualified Git
 import Git.Command
+import Utility.ThreadScheduler
 
 import Control.Concurrent.Chan
 import Control.Concurrent.Async
-import System.Process (std_in, std_out)
+import System.Process (std_in, std_out, std_err)
 
 transport :: Transport
-transport r remotename transporthandle ichan ochan = do
+transport r url h@(TransportHandle g s) ichan ochan = do
+	-- enable ssh connection caching wherever inLocalRepo is called
+	g' <- liftAnnex h $ sshCachingTo r g
+	transport' r url (TransportHandle g' s) ichan ochan
+
+transport' :: Transport
+transport' r url transporthandle ichan ochan = do
+
 	v <- liftAnnex transporthandle $ git_annex_shell r "notifychanges" [] []
 	case v of
 		Nothing -> noop
-		Just (cmd, params) -> go cmd (toCommand params)
+		Just (cmd, params) -> robustly 1 $
+			connect cmd (toCommand params)
   where
-	go cmd params = do
+	connect cmd params = do
-		(Just toh, Just fromh, _, pid) <- createProcess (proc cmd params)
+		(Just toh, Just fromh, Just errh, pid) <-
+			createProcess (proc cmd params)
 			{ std_in = CreatePipe
 			, std_out = CreatePipe
+			, std_err = CreatePipe
 			}
 		
-		let shutdown = do
+		-- Run all threads until one finishes and get the status
-			hClose toh
+		-- of the first to finish. Cancel the rest.
-			hClose fromh
+		status <- catchDefaultIO (Right ConnectionClosed) $
-			void $ waitForProcess pid
+			handlestderr errh
-			send DISCONNECTED
+				`race` handlestdout fromh
+					`race` handlecontrol
 
-		let fromshell = forever $ do
+		send (DISCONNECTED url)
-			l <- hGetLine fromh
+		hClose toh
-			case parseMessage l of
+		hClose fromh
-				Just SshRemote.READY -> send CONNECTED
+		void $ waitForProcess pid
-				Just (SshRemote.CHANGED shas) ->
-					whenM (checkNewShas transporthandle shas) $
-						fetch
-				Nothing -> shutdown
 
-		-- The only control message that matters is STOP.
+		return $ either (either id id) id status
-		--
-		-- Note that a CHANGED control message is not handled;
-		-- we don't push to the ssh remote. The assistant
-		-- and git-annex sync both handle pushes, so there's no
-		-- need to do it here.
-		let handlecontrol = forever $ do
-			msg <- readChan ichan
-			case msg of
-				STOP -> ioError (userError "done")
-				_ -> noop
 
-		-- Run both threads until one finishes.
+	send msg = writeChan ochan msg
-		void $ tryIO $ concurrently fromshell handlecontrol
-		shutdown
-
-	send msg = writeChan ochan (msg remotename)
 
 	fetch = do
-		send SYNCING
+		send (SYNCING url)
 		ok <- inLocalRepo transporthandle $
-			runBool [Param "fetch", Param remotename]
+			runBool [Param "fetch", Param $ Git.repoDescribe r]
-		send (DONESYNCING ok)
+		send (DONESYNCING url ok)
+		
+	handlestdout fromh = do
+		l <- hGetLine fromh
+		case parseMessage l of
+			Just SshRemote.READY -> do
+				send (CONNECTED url)
+				handlestdout fromh
+			Just (SshRemote.CHANGED shas) -> do
+				whenM (checkNewShas transporthandle shas) $
+					fetch
+				handlestdout fromh
+			-- avoid reconnect on protocol error
+			Nothing -> return Stopping
+	
+	handlecontrol = do
+		msg <- readChan ichan
+		case msg of
+			STOP -> return Stopping
+			LOSTNET -> return Stopping
+			_ -> handlecontrol
+
+	-- Old versions of git-annex-shell that do not support
+	-- the notifychanges command will exit with a not very useful
+	-- error message. Detect that error, and avoid reconnecting.
+	-- Propigate all stderr.
+	handlestderr errh = do
+		s <- hGetSomeString errh 1024
+		hPutStr stderr s
+		hFlush stderr
+		if "git-annex-shell: git-shell failed" `isInfixOf` s
+			then do
+				send $ WARNING url $ unwords
+					[ "Remote", Git.repoDescribe r
+					, "needs its git-annex upgraded"
+					, "to 5.20140405 or newer"
+					]
+				return Stopping
+			else handlestderr errh
+
+data Status = Stopping | ConnectionClosed
+
+{- Make connection robustly, with exponentioal backoff on failure. -}
+robustly :: Int -> IO Status -> IO ()
+robustly backoff a = handle =<< catchDefaultIO ConnectionClosed a
+  where
+	handle Stopping = return ()
+	handle ConnectionClosed = do
+		threadDelaySeconds (Seconds backoff)
+		robustly increasedbackoff a
+
+	increasedbackoff
+		| b2 > maxbackoff = maxbackoff
+		| otherwise = b2
+	  where
+	  	b2 = backoff * 2
+		maxbackoff = 3600 -- one hour

RemoteDaemon/Types.hs

@@ -10,38 +10,51 @@
 
 module RemoteDaemon.Types where
 
+import Common
 import qualified Annex
 import qualified Git.Types as Git
 import qualified Utility.SimpleProtocol as Proto
 
+import Network.URI
 import Control.Concurrent
 
+-- The URI of a remote is used to uniquely identify it (names change..)
+newtype RemoteURI = RemoteURI URI
+  deriving (Show)
+
 -- A Transport for a particular git remote consumes some messages
 -- from a Chan, and emits others to another Chan.
-type Transport = RemoteRepo -> RemoteName -> TransportHandle -> Chan Consumed -> Chan Emitted -> IO ()
+type Transport = RemoteRepo -> RemoteURI -> TransportHandle -> Chan Consumed -> Chan Emitted -> IO ()
 
 type RemoteRepo = Git.Repo
 type LocalRepo = Git.Repo
 
 -- All Transports share a single AnnexState MVar
+--
+-- Different TransportHandles may have different versions of the LocalRepo.
+-- (For example, the ssh transport modifies it to enable ssh connection
+-- caching.)
 data TransportHandle = TransportHandle LocalRepo (MVar Annex.AnnexState)
 
 -- Messages that the daemon emits.
 data Emitted
-	= CONNECTED RemoteName
+	= CONNECTED RemoteURI
-	| DISCONNECTED RemoteName
+	| DISCONNECTED RemoteURI
-	| SYNCING RemoteName
+	| SYNCING RemoteURI
-	| DONESYNCING Bool RemoteName
+	| DONESYNCING RemoteURI Bool
+	| WARNING RemoteURI String
+	deriving (Show)
 
 -- Messages that the deamon consumes.
 data Consumed
 	= PAUSE
+	| LOSTNET
 	| RESUME
 	| CHANGED RefList
 	| RELOAD
 	| STOP
+	deriving (Show)
 
-type RemoteName = String
 type RefList = [Git.Ref]
 
 instance Proto.Sendable Emitted where
@@ -51,11 +64,14 @@ instance Proto.Sendable Emitted where
 		["DISCONNECTED", Proto.serialize remote]
 	formatMessage (SYNCING remote) =
 		["SYNCING", Proto.serialize remote]
-	formatMessage (DONESYNCING status remote) =
+	formatMessage (DONESYNCING remote status) =
-		["DONESYNCING", Proto.serialize status, Proto.serialize remote]
+		["DONESYNCING", Proto.serialize remote, Proto.serialize status]
+	formatMessage (WARNING remote message) =
+		["WARNING", Proto.serialize remote, Proto.serialize message]
 
 instance Proto.Sendable Consumed where
 	formatMessage PAUSE = ["PAUSE"]
+	formatMessage LOSTNET = ["LOSTNET"]
 	formatMessage RESUME = ["RESUME"]
 	formatMessage (CHANGED refs) =["CHANGED", Proto.serialize refs]
 	formatMessage RELOAD = ["RELOAD"]
@@ -66,16 +82,22 @@ instance Proto.Receivable Emitted where
 	parseCommand "DISCONNECTED" = Proto.parse1 DISCONNECTED
 	parseCommand "SYNCING" = Proto.parse1 SYNCING
 	parseCommand "DONESYNCING" = Proto.parse2 DONESYNCING
+	parseCommand "WARNING" = Proto.parse2 WARNING
 	parseCommand _ = Proto.parseFail
 
 instance Proto.Receivable Consumed where
 	parseCommand "PAUSE" = Proto.parse0 PAUSE
+	parseCommand "LOSTNET" = Proto.parse0 LOSTNET
 	parseCommand "RESUME" = Proto.parse0 RESUME
 	parseCommand "CHANGED" = Proto.parse1 CHANGED
 	parseCommand "RELOAD" = Proto.parse0 RELOAD
 	parseCommand "STOP" = Proto.parse0 STOP
 	parseCommand _ = Proto.parseFail
 
+instance Proto.Serializable RemoteURI where
+	serialize (RemoteURI u) = show u
+	deserialize = RemoteURI <$$> parseURI
+
 instance Proto.Serializable [Char] where
 	serialize = id
 	deserialize = Just

Test.hs

@@ -164,6 +164,7 @@ properties = localOption (QuickCheckTests 1000) $ testGroup "QuickCheck"
 	, testProperty "prop_parse_show_TrustLog" Logs.Trust.prop_parse_show_TrustLog
 	, testProperty "prop_hashes_stable" Utility.Hash.prop_hashes_stable
 	, testProperty "prop_schedule_roundtrips" Utility.Scheduled.prop_schedule_roundtrips
+	, testProperty "prop_past_sane" Utility.Scheduled.prop_past_sane
 	, testProperty "prop_duration_roundtrips" Utility.HumanTime.prop_duration_roundtrips
 	, testProperty "prop_metadata_sane" Types.MetaData.prop_metadata_sane
 	, testProperty "prop_metadata_serialize" Types.MetaData.prop_metadata_serialize
@@ -711,7 +712,7 @@ test_unused env = intmpclonerepoInDirect env $ do
 			(sort expectedkeys) (sort unusedkeys)
 	findkey f = do
 		r <- Backend.lookupFile f
-		return $ fst $ fromJust r
+		return $ fromJust r
 
 test_describe :: TestEnv -> Assertion
 test_describe env = intmpclonerepo env $ do
@@ -1232,7 +1233,7 @@ test_crypto env = do
 			(c,k) <- annexeval $ do
 				uuid <- Remote.nameToUUID "foo"
 				rs <- Logs.Remote.readRemoteLog
-				Just (k,_) <- Backend.lookupFile annexedfile
+				Just k <- Backend.lookupFile annexedfile
 				return (fromJust $ M.lookup uuid rs, k)
 			let key = if scheme `elem` ["hybrid","pubkey"]
 					then Just $ Utility.Gpg.KeyIds [Utility.Gpg.testKeyId]
@@ -1499,7 +1500,7 @@ checklocationlog f expected = do
 	thisuuid <- annexeval Annex.UUID.getUUID
 	r <- annexeval $ Backend.lookupFile f
 	case r of
-		Just (k, _) -> do
+		Just k -> do
 			uuids <- annexeval $ Remote.keyLocations k
 			assertEqual ("bad content in location log for " ++ f ++ " key " ++ Types.Key.key2file k ++ " uuid " ++ show thisuuid)
 				expected (thisuuid `elem` uuids)
@@ -1507,9 +1508,9 @@ checklocationlog f expected = do
 
 checkbackend :: FilePath -> Types.Backend -> Assertion
 checkbackend file expected = do
-	r <- annexeval $ Backend.lookupFile file
+	b <- annexeval $ maybe (return Nothing) (Backend.getBackend file) 
-	let b = snd $ fromJust r
+		=<< Backend.lookupFile file
-	assertEqual ("backend for " ++ file) expected b
+	assertEqual ("backend for " ++ file) (Just expected) b
 
 inlocationlog :: FilePath -> Assertion
 inlocationlog f = checklocationlog f True

Types/UUID.hs

@@ -8,6 +8,8 @@
 module Types.UUID where
 
 import qualified Data.Map as M
+import qualified Data.UUID as U
+import Data.Maybe
 
 -- A UUID is either an arbitrary opaque string, or UUID info may be missing.
 data UUID = NoUUID | UUID String
@@ -21,4 +23,7 @@ toUUID :: String -> UUID
 toUUID [] = NoUUID
 toUUID s = UUID s
 
+isUUID :: String -> Bool
+isUUID = isJust . U.fromString
+
 type UUIDMap = M.Map UUID String

Utility/Process.hs

@@ -31,6 +31,7 @@ module Utility.Process (
 	stdinHandle,
 	stdoutHandle,
 	stderrHandle,
+	processHandle,
 	devNull,
 ) where
 
@@ -313,6 +314,9 @@ bothHandles :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> (Han
 bothHandles (Just hin, Just hout, _, _) = (hin, hout)
 bothHandles _ = error "expected bothHandles"
 
+processHandle :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> ProcessHandle
+processHandle (_, _, _, pid) = pid
+
 {- Debugging trace for a CreateProcess. -}
 debugProcess :: CreateProcess -> IO ()
 debugProcess p = do

Utility/Scheduled.hs

@@ -1,6 +1,6 @@
 {- scheduled activities
  - 
- - Copyright 2013 Joey Hess <joey@kitenet.net>
+ - Copyright 2013-2014 Joey Hess <joey@kitenet.net>
  -
  - Licensed under the GNU GPL version 3 or higher.
  -}
@@ -14,6 +14,7 @@ module Utility.Scheduled (
 	MonthDay,
 	YearDay,
 	nextTime,
+	calcNextTime,
 	startTime,
 	fromSchedule,
 	fromScheduledTime,
@@ -22,7 +23,8 @@ module Utility.Scheduled (
 	toRecurrance,
 	toSchedule,
 	parseSchedule,
-	prop_schedule_roundtrips
+	prop_schedule_roundtrips,
+	prop_past_sane,
 ) where
 
 import Utility.Data
@@ -66,8 +68,8 @@ data ScheduledTime
 type Hour = Int
 type Minute = Int
 
-{- Next time a Schedule should take effect. The NextTimeWindow is used
+-- | Next time a Schedule should take effect. The NextTimeWindow is used
- - when a Schedule is allowed to start at some point within the window. -}
+-- when a Schedule is allowed to start at some point within the window.
 data NextTime
 	= NextTimeExactly LocalTime
 	| NextTimeWindow LocalTime LocalTime
@@ -83,8 +85,8 @@ nextTime schedule lasttime = do
 	tz <- getTimeZone now
 	return $ calcNextTime schedule lasttime $ utcToLocalTime tz now
 
-{- Calculate the next time that fits a Schedule, based on the
+-- | Calculate the next time that fits a Schedule, based on the
- - last time it occurred, and the current time. -}
+-- last time it occurred, and the current time.
 calcNextTime :: Schedule -> Maybe LocalTime -> LocalTime -> Maybe NextTime
 calcNextTime schedule@(Schedule recurrance scheduledtime) lasttime currenttime
 	| scheduledtime == AnyTime = do
@@ -97,10 +99,10 @@ calcNextTime schedule@(Schedule recurrance scheduledtime) lasttime currenttime
   	findfromtoday anytime = findfrom recurrance afterday today
 	  where
 	  	today = localDay currenttime
-		afterday = sameaslastday || toolatetoday
+		afterday = sameaslastrun || toolatetoday
 		toolatetoday = not anytime && localTimeOfDay currenttime >= nexttime
-		sameaslastday = lastday == Just today
+		sameaslastrun = lastrun == Just today
-	lastday = localDay <$> lasttime
+	lastrun = localDay <$> lasttime
 	nexttime = case scheduledtime of
 		AnyTime -> TimeOfDay 0 0 0
 		SpecificTime h m -> TimeOfDay h m 0
@@ -120,21 +122,19 @@ calcNextTime schedule@(Schedule recurrance scheduledtime) lasttime currenttime
 			| otherwise -> Just $ exactly candidate
 		Weekly Nothing
 			| afterday -> skip 1
-			| otherwise -> case (wday <$> lastday, wday candidate) of
+			| otherwise -> case (wday <$> lastrun, wday candidate) of
 				(Nothing, _) -> Just $ window candidate (addDays 6 candidate)
 				(Just old, curr)
 					| old == curr -> Just $ window candidate (addDays 6 candidate)
 					| otherwise -> skip 1
 		Monthly Nothing
 			| afterday -> skip 1
-			| maybe True (\old -> mday candidate > mday old && mday candidate >= (mday old `mod` minmday)) lastday ->
+			| maybe True (candidate `oneMonthPast`) lastrun ->
-				-- Window only covers current month,
-				-- in case there is a Divisible requirement.
 				Just $ window candidate (endOfMonth candidate)
 			| otherwise -> skip 1
 		Yearly Nothing
 			| afterday -> skip 1
-			| maybe True (\old -> ynum candidate > ynum old && yday candidate >= (yday old `mod` minyday)) lastday ->
+			| maybe True (candidate `oneYearPast`) lastrun ->
 				Just $ window candidate (endOfYear candidate)
 			| otherwise -> skip 1
 		Weekly (Just w)
@@ -176,6 +176,18 @@ calcNextTime schedule@(Schedule recurrance scheduledtime) lasttime currenttime
 		getday = localDay . startTime
 	divisible n v = v `rem` n == 0
 
+-- Check if the new Day occurs one month or more past the old Day.
+oneMonthPast :: Day -> Day -> Bool
+new `oneMonthPast` old = fromGregorian y (m+1) d <= new
+  where
+	(y,m,d) = toGregorian old
+
+-- Check if the new Day occurs one year or more past the old Day.
+oneYearPast :: Day -> Day -> Bool
+new `oneYearPast` old = fromGregorian (y+1) m d <= new
+  where
+	(y,m,d) = toGregorian old
+
 endOfMonth :: Day -> Day
 endOfMonth day =
 	let (y,m,_d) = toGregorian day
@@ -200,17 +212,13 @@ yday = snd . toOrdinalDate
 ynum :: Day -> Int
 ynum = fromIntegral . fst . toOrdinalDate
 
-{- Calendar max and mins. -}
+-- Calendar max values.
 maxyday :: Int
 maxyday = 366 -- with leap days
-minyday :: Int
-minyday = 365
 maxwnum :: Int
 maxwnum = 53 -- some years have more than 52
 maxmday :: Int
 maxmday = 31
-minmday :: Int
-minmday = 28
 maxmnum :: Int
 maxmnum = 12
 maxwday :: Int
@@ -362,3 +370,27 @@ instance Arbitrary Recurrance where
 
 prop_schedule_roundtrips :: Schedule -> Bool
 prop_schedule_roundtrips s = toSchedule (fromSchedule s) == Just s
+
+prop_past_sane :: Bool
+prop_past_sane = and
+	[ all (checksout oneMonthPast) (mplus1 ++ yplus1)
+	, all (not . (checksout oneMonthPast)) (map swap (mplus1 ++ yplus1))
+	, all (checksout oneYearPast) yplus1
+	, all (not . (checksout oneYearPast)) (map swap yplus1)
+	]
+  where
+	mplus1 =   -- new date               old date, 1+ months before it
+		[ (fromGregorian 2014 01 15, fromGregorian 2013 12 15)
+		, (fromGregorian 2014 01 15, fromGregorian 2013 02 15)
+		, (fromGregorian 2014 02 15, fromGregorian 2013 01 15)
+		, (fromGregorian 2014 03 01, fromGregorian 2013 01 15)
+		, (fromGregorian 2014 03 01, fromGregorian 2013 12 15)
+		, (fromGregorian 2015 01 01, fromGregorian 2010 01 01)
+		]
+	yplus1 =   -- new date               old date, 1+ years before it
+		[ (fromGregorian 2014 01 15, fromGregorian 2012 01 16)
+		, (fromGregorian 2014 01 15, fromGregorian 2013 01 14)
+		, (fromGregorian 2022 12 31, fromGregorian 2000 01 01)
+		]
+	checksout cmp (new, old) = new `cmp` old
+	swap (a,b) = (b,a)

debian/changelog

@@ -1,3 +1,45 @@
+git-annex (5.20140421) unstable; urgency=medium
+
+  * assistant: Now detects immediately when other repositories push
+    changes to a ssh remote, and pulls.
+    ** XMPP is no longer needed in this configuration! **
+    This requires the remote server have git-annex-shell with
+    notifychanges support (>= 5.20140405)
+  * webapp: Show a network signal icon next to ssh and xmpp remotes that
+    it's currently connected with.
+  * webapp: Rework xmpp nudge to prompt for either xmpp or a ssh remote 
+    to be set up.
+  * sync, assistant, remotedaemon: Use ssh connection caching for git pushes
+    and pulls.
+  * remotedaemon: When network connection is lost, close all cached ssh
+    connections.
+  * Improve handling of monthly/yearly scheduling.
+  * Avoid depending on shakespeare except for when building the webapp.
+  * uninit: Avoid making unncessary copies of files.
+  * info: Allow use in a repository where annex.uuid is not set.
+  * reinit: New command that can initialize a new repository using
+    the configuration of a previously known repository.
+    Useful if a repository got deleted and you want
+    to clone it back the way it was.
+  * drop --from: When local repository is untrusted, its copy of a file does
+    not count.
+  * Bring back rsync -p, but only when git-annex is running on a non-crippled
+    file system. This is a better approach to fix #700282 while not
+    unncessarily losing file permissions on non-crippled systems.
+  * webapp: Start even if the current directory is listed in
+    ~/.config/git-annex/autostart but no longer has a git repository in it.
+  * findref: New command, like find but shows files in a specified git ref.
+  * webapp: Fix UI for removing XMPP connection.
+  * When init detects that git is not configured to commit, and sets
+    user.email to work around the problem, also make it set user.name.
+  * webapp: Support using git-annex on a remote server, which was installed
+    from the standalone tarball or OSX app, and so does not have
+    git-annex in PATH (and may also not have git or rsync in PATH).
+  * standalone tarball, OSX app: Install a ~/.ssh/git-annex-wrapper, which
+    can be used to run git-annex, git, rsync, etc.
+
+ -- Joey Hess <joeyh@debian.org>  Sun, 20 Apr 2014 19:43:14 -0400
+
 git-annex (5.20140412) unstable; urgency=high
 
   * Last release didn't quite fix the high cpu issue in all cases, this should.

debian/control

@@ -34,6 +34,7 @@ Build-Depends:
 	libghc-yesod-static-dev [i386 amd64 kfreebsd-i386 kfreebsd-amd64 powerpc sparc],
 	libghc-yesod-default-dev [i386 amd64 kfreebsd-amd64 powerpc sparc],
 	libghc-hamlet-dev [i386 amd64 kfreebsd-i386 kfreebsd-amd64 powerpc sparc],
+	libghc-shakespeare-dev [i386 amd64 kfreebsd-i386 kfreebsd-amd64 powerpc sparc],
 	libghc-clientsession-dev [i386 amd64 kfreebsd-i386 kfreebsd-amd64 powerpc sparc],
 	libghc-warp-dev [i386 amd64 kfreebsd-i386 kfreebsd-amd64 powerpc sparc],
 	libghc-warp-tls-dev [i386 amd64 kfreebsd-i386 kfreebsd-amd64 powerpc sparc],

doc/automatic_conflict_resolution/comment_6_8a0860fee88f5954918305f055a39d8d._comment

@@ -0,0 +1,10 @@
+[[!comment format=mdwn
+ username="https://www.google.com/accounts/o8/id?id=AItOawn3p4i4lk_zMilvjnJ9sS6g2nerpgz0Fjc"
+ nickname="Matthias"
+ subject="auto conflict resolution master branch"
+ date="2014-04-13T17:48:19Z"
+ content="""
+@joeyh: This must be a misunderstanding of what I want. I use version 5.20140320. I can't find a workflow where \"git annex merge\" changes my master branch, it only updates the git-annex branch.
+
+Thinking again of it after some time, I am basically fine with \"git annex sync\". The only thing I am uncomfortable with is that the automatic merge is pushed without review.
+"""]]

doc/automatic_conflict_resolution/comment_7_3d2250cc26036b8532faa980065e20d0._comment

@@ -0,0 +1,23 @@
+[[!comment format=mdwn
+ username="http://joeyh.name/"
+ ip="209.250.56.191"
+ subject="comment 7"
+ date="2014-04-17T20:00:22Z"
+ content="""
+@Matthias, here is an example of git-annex merge updating the master branch from the synced/master branch that was pushed to it earlier:
+
+<pre>
+joey@darkstar:~/tmp/test/2>git annex merge
+merge git-annex (merging synced/git-annex into git-annex...)
+ok
+merge synced/master 
+Updating 7942eee..1f3422e
+Fast-forward
+ new_file | 1 +
+ 1 file changed, 1 insertion(+)
+ create mode 120000 new_file
+ok
+</pre>
+
+If you are having trouble with it somehow, I'd suggest filing a bug report.
+"""]]

doc/automatic_conflict_resolution/comment_8_ef474c258ce8e0ebc6485c1366ae6315._comment

@@ -0,0 +1,8 @@
+[[!comment format=mdwn
+ username="https://www.google.com/accounts/o8/id?id=AItOawn3p4i4lk_zMilvjnJ9sS6g2nerpgz0Fjc"
+ nickname="Matthias"
+ subject="auto conflict resolution"
+ date="2014-04-19T17:26:11Z"
+ content="""
+Thanks Joey, I could construct a scenario where the auto-conflict-resolution was applied in the master branch.
+"""]]

doc/bugs/Android___91__Terminal_session_finished__93__.mdwn

@@ -0,0 +1,33 @@
+### Please describe the problem.
+
+Launching the Git Annex app on Android, the shell just reads:
+[[!format sh """
+[Terminal session finished]
+"""]]
+
+Attempting to launch /data/data/ga.androidterm/runshell via the adb shell does also not work:
+[[!format sh """
+/system/bin/sh: /data/data/ga.androidterm/runshell: not found
+"""]]
+
+Listing the contents of that directory from the git annex terminal appears to confirm this:
+[[!format sh """
+u0_a172@android:/data/data/ga.androidterm $ ls
+cache
+lib
+shared_prefs
+"""]]
+
+Following the instructions for the similar issue here [[http://git-annex.branchable.com/Android/oldcomments/#comment-4c5a944c1288ddd46108969a4c664584]]:
+[[!format sh """
+u0_a172@android:/ $ ls -ld /data/data/ga.androidterm
+drwxr-x--x u0_a172  u0_a172           2014-04-20 11:12 ga.androidterm
+"""]]
+
+### What version of git-annex are you using? On what operating system?
+
+version 5.20140413 of the Git Annex app (tested using the daily build and regular build).
+
+Samsung Galaxy Tab 3 (GT-P5210) running Android 4.2.2 (without root access).
+
+> [[done|dup]] --[[Joey]]

doc/bugs/Android___91__Terminal_session_finished__93__/comment_1_31af3e5226430a4e94de58c0e33bd22b._comment

@@ -0,0 +1,12 @@
+[[!comment format=mdwn
+ username="http://joeyh.name/"
+ ip="209.250.56.191"
+ subject="comment 1"
+ date="2014-04-20T17:16:50Z"
+ content="""
+From the git-annex terminal, try to run:
+
+/data/data/ga.androidterm/lib/lib.start.so
+
+Paste me any output..
+"""]]

doc/bugs/Android___91__Terminal_session_finished__93__/comment_2_a5bcbd2f85283e29e237e9850cd8109a._comment

@@ -0,0 +1,22 @@
+[[!comment format=mdwn
+ username="cbaines"
+ ip="86.166.14.171"
+ subject="comment 2"
+ date="2014-04-20T19:40:11Z"
+ content="""
+When I run that, I get:
+[[!format sh \"\"\"
+/system/bin/sh: /data/data/ga.androidterm/lib/lib.start.so: not found
+\"\"\"]]
+
+Which makes some sense, as the file is not there. The following files can be found under /data/data/ga.androidterm:
+[[!format sh \"\"\"
+/data/data/ga.androidterm/cache/com.android.renderscript.cache/ <- empty directory
+/data/data/ga.androidterm/lib/libga-androidterm4.so
+/data/data/ga.androidterm/shared_prefs/ga.androidterm_preferences.xml
+\"\"\"]]
+
+I tried running libga-androidterm4.so, but I just got Segmentation fault back.
+
+I also tried using logcat to see if I could see anything obvious going wrong when running the app for the first time after installation, but I could not see anything obvious in the logs (there was a lot of noise, so I might of missed something), will anything useful appear with the use of a filter?
+"""]]

doc/bugs/Android___91__Terminal_session_finished__93__/comment_3_965efa6736dcff4d7010ea5533f31a59._comment

@@ -0,0 +1,8 @@
+[[!comment format=mdwn
+ username="cbaines"
+ ip="86.166.14.171"
+ subject="comment 3"
+ date="2014-04-20T19:50:12Z"
+ content="""
+Looking at the contents of the apk for the x86 architecture (which this tablet is), would you expect that file to be there? That file only appears in the /lib/armeabi and not /lib/x86 ?
+"""]]

doc/bugs/Android___91__Terminal_session_finished__93__/comment_4_90a0be2296b4a1d8c1708423666c9619._comment

@@ -0,0 +1,31 @@
+[[!comment format=mdwn
+ username="http://joeyh.name/"
+ ip="209.250.56.191"
+ subject="comment 4"
+ date="2014-04-20T19:55:59Z"
+ content="""
+Ok, so the git-annex.apk ships several libraries (and pseudo-libraries), and it seems your version of Android only installed the one that is really an Android java application. I don't know why.
+
+Here's the full list of files that are supposed to be installed in the lib dir. If you can find something about them in the logs, that might help.
+
+I suppose it's possible they were installed to some other location in the android file system (which might be hard to find w/o root.. You could check if git-annex in the app list has a larger installed size than the size of libga-androidterm4.so, that might give a hint.
+
+<pre>
+lib.busybox.so
+lib.git-annex.so
+lib.git-shell.so
+lib.git-upload-pack.so
+lib.git.so
+lib.git.tar.gz.so
+lib.gpg.so
+lib.rsync.so
+lib.runshell.so
+lib.ssh-keygen.so
+lib.ssh.so
+lib.start.so
+lib.version.so
+libga-androidterm4.so
+</pre>
+
+(I just installed the 5.20140414-gb70cd37 autobuild on an android device and it worked ok.)
+"""]]

doc/bugs/Android___91__Terminal_session_finished__93__/comment_5_be4b720293992f75b9cc3e8f6687fb87._comment

@@ -0,0 +1,8 @@
+[[!comment format=mdwn
+ username="cbaines"
+ ip="86.166.14.171"
+ subject="comment 5"
+ date="2014-04-20T20:20:55Z"
+ content="""
+I'm guessing you missed my last comment regarding the architecture. Sorry I did not pick this up earlier, but it only came to mind when I had a poke around in the apk?
+"""]]

doc/bugs/Android___91__Terminal_session_finished__93__/comment_6_8e439138c97b8853ab2b6f96f6111568._comment

@@ -0,0 +1,8 @@
+[[!comment format=mdwn
+ username="http://joeyh.name/"
+ ip="209.250.56.191"
+ subject="comment 6"
+ date="2014-04-20T20:58:22Z"
+ content="""
+Yes, that fully explains it. git-annex is a native program and for android it's only built for arm.
+"""]]

doc/bugs/Android___91__Terminal_session_finished__93__/comment_7_6142516d816f78c724e22737aa3bca53._comment

@@ -0,0 +1,8 @@
+[[!comment format=mdwn
+ username="http://joeyh.name/"
+ ip="209.250.56.191"
+ subject="comment 7"
+ date="2014-04-20T20:59:35Z"
+ content="""
+So, this is a dup of [[todo/Not_working_on_Android-x86]]
+"""]]

doc/bugs/Drop_--from_always_trusts_local_repository.mdwn

@@ -0,0 +1,46 @@
+### Please describe the problem.
+
+The command `git annex drop --from` always trusts the local repository, even if
+it is marked as untrusted.
+
+
+### What steps will reproduce the problem?
+[[!format sh """
+mkdir t u; cd t; git init; git commit --allow-empty -m "Initial commit"; git annex init "Trusted"; date > file; git annex add file; git commit -m "Add file"; cd ../u; git init; git remote add t ../t; git fetch t; git merge t/master; git annex init "Untrusted"; git annex untrust .; git annex get file; cd ../t; git remote add u ../u; git fetch u; cd ..
+"""]]
+
+Create two repositories, *t* (trusted) and *u* (untrusted). A file is in both
+repositories. When performing `git annex drop file` in repository *t*, `git
+annex` will abort because there are not enough copies. But when performing `git
+annex drop --from t file` in *u*, git annex will delete the copy.
+
+
+### What version of git-annex are you using? On what operating system?
+
+Bug was introduced with 6c31e3a8 and still exists in current master (d955cfe7).
+
+
+### Please provide any additional information below.
+
+The following change seems to solve the problem. (First time working with
+Haskell, please excuse the crude code.)
+
+[[!format diff """
+diff --git a/Command/Drop.hs b/Command/Drop.hs
+index 269c4c2..09ea99a 100644
+--- a/Command/Drop.hs
++++ b/Command/Drop.hs
+@@ -82,8 +82,9 @@ performRemote key afile numcopies remote = lockContent key $ do
+        (remotes, trusteduuids) <- Remote.keyPossibilitiesTrusted key
+        present <- inAnnex key
+        u <- getUUID
++       level <- lookupTrust u
+        let have = filter (/= uuid) $
+-               if present then u:trusteduuids else trusteduuids
++               if present && level <= SemiTrusted then u:trusteduuids else trusteduuids
+        untrusteduuids <- trustGet UnTrusted
+        let tocheck = filter (/= remote) $
+                Remote.remotesWithoutUUID remotes (have++untrusteduuids)
+"""]]
+
+> [[fixed|done]] --[[Joey]]

doc/bugs/fatal:_Out_of_memory__63___mmap_failed:_No_error.mdwn

@@ -0,0 +1,31 @@
+### Please describe the problem.
+
+When adding files, the error
+
+ fatal: Out of memory? mmap failed: No error
+
+appears 
+
+
+### What steps will reproduce the problem?
+
+In Windows, I have a directory with 8GB and 333.820 files (of course, in different directory, the big one is probably the Android SDK).
+
+### What version of git-annex are you using? On what operating system?
+
+Windows 8.
+
+ $ git annex version
+ git-annex version: 5.20140411-gda795e0
+ build flags: Assistant Webapp Webapp-secure Pairing Testsuite S3 WebDAV DNS Feeds Quvi TDFA CryptoHash
+ key/value backends: SHA256E SHA1E SHA512E SHA224E SHA384E SKEIN256E SKEIN512E SHA256 SHA1 SHA512 SHA224 SHA384 SKEIN256 SKEIN512 WORM URL
+ remote types: git gcrypt S3 bup directory rsync web webdav tahoe glacier hook external
+ local repository version: 5
+ supported repository version: 5
+ upgrade supported from repository versions: 2 3 4
+
+
+### Please provide any additional information below.
+
+
+> closing as not a git-annex bug at all, but a git bug. [[done]] --[[Joey]]