Automatically detect when a ssh remote does not have git-annex-shell installed, and set annex-ignore.

Aka solve the github problem.

Note that it's possible the initial configlist will fail for some network
reason etc, and then the fetch succeeds. In this case, a usable remote gets
disabled. But it does print a message, and this only happens once per
remote, so that seems ok.

2 files changed, 22 insertions, 3 deletions

diff --git a/Remote/Git.hs b/Remote/Git.hs
index df97db7a6..cc524fd30 100644
--- a/Remote/Git.hs
+++ b/Remote/Git.hs
@@ -22,6 +22,7 @@ import Types.Remote
 import qualified Git
 import qualified Git.Config
 import qualified Git.Construct
+import qualified Git.Command
 import qualified Annex
 import Logs.Presence
 import Logs.Transfer
@@ -126,7 +127,20 @@ guardUsable r onerr a
 tryGitConfigRead :: Git.Repo -> Annex Git.Repo
 tryGitConfigRead r 
 	| not $ M.null $ Git.config r = return r -- already read
-	| Git.repoIsSsh r = store $ onRemote r (pipedconfig, r) "configlist" [] []
+	| Git.repoIsSsh r = store $ do
+		v <- onRemote r (pipedsshconfig, Left undefined) "configlist" [] []
+		case (v, Git.remoteName r) of
+			(Right r', _) -> return r'
+			(Left _, Just n) -> do
+				{- Is this remote just not available, or does
+				 - it not have git-annex-shell?
+				 - Find out by trying to fetch from the remote. -}
+				whenM (inRepo $ Git.Command.runBool "fetch" [Param "--quiet", Param n]) $ do
+					let k = "remote." ++ n ++ ".annex-ignore"
+					warning $ "Remote " ++ n ++ " does not have git-annex installed; setting " ++ k
+					inRepo $ Git.Command.run "config" [Param k, Param "true"]
+				return r
+			_ -> return r
 	| Git.repoIsHttp r = do
 		headers <- getHttpHeaders
 		store $ safely $ geturlconfig headers
@@ -140,18 +154,21 @@ tryGitConfigRead r
 		safely a = either (const $ return r) return
 				=<< liftIO (try a :: IO (Either SomeException Git.Repo))
 
-		pipedconfig cmd params = safely $
+		pipedconfig cmd params =
 			withHandle StdoutHandle createProcessSuccess p $
 				Git.Config.hRead r
 			where
 				p = proc cmd $ toCommand params
 
+		pipedsshconfig cmd params =
+			liftIO (try (pipedconfig cmd params) :: IO (Either SomeException Git.Repo))
+
 		geturlconfig headers = do
 			s <- Url.get (Git.repoLocation r ++ "/config") headers
 			withTempFile "git-annex.tmp" $ \tmpfile h -> do
 				hPutStr h s
 				hClose h
-				pipedconfig "git" [Param "config", Param "--null", Param "--list", Param "--file", File tmpfile]
+				safely $ pipedconfig "git" [Param "config", Param "--null", Param "--list", Param "--file", File tmpfile]
 
 		store = observe $ \r' -> do
 			g <- gitRepo
diff --git a/debian/changelog b/debian/changelog
index b3e825560..10430856b 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -15,6 +15,8 @@ git-annex (3.20121010) UNRELEASED; urgency=low
     a remote gets synced.
   * Fix a crash when merging files in the git-annex branch that contain
     invalid utf8.
+  * Automatically detect when a ssh remote does not have git-annex-shell
+    installed, and set annex-ignore.
 
  -- Joey Hess <joeyh@debian.org>  Wed, 10 Oct 2012 12:59:25 -0400