1 files changed, 80 insertions, 37 deletions

diff --git a/RemoteDaemon/Transport/Ssh.hs b/RemoteDaemon/Transport/Ssh.hs
index 557a3dce9..87fcf6f8c 100644
--- a/RemoteDaemon/Transport/Ssh.hs
+++ b/RemoteDaemon/Transport/Ssh.hs
@@ -13,60 +13,103 @@ 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 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
-		(Just toh, Just fromh, _, pid) <- createProcess (proc cmd params)
+	connect cmd params = do
+		(Just toh, Just fromh, Just errh, pid) <-
+			createProcess (proc cmd params)
 			{ std_in = CreatePipe
 			, std_out = CreatePipe
+			, std_err = CreatePipe
 			}
 		
-		let shutdown = do
-			hClose toh
-			hClose fromh
-			void $ waitForProcess pid
-			send DISCONNECTED
+		-- Run all threads until one finishes and get the status
+		-- of the first to finish. Cancel the rest.
+		status <- catchDefaultIO (Right ConnectionClosed) $
+			handlestderr errh
+				`race` handlestdout fromh
+					`race` handlecontrol
 
-		let fromshell = forever $ do
-			l <- hGetLine fromh
-			case parseMessage l of
-				Just SshRemote.READY -> send CONNECTED
-				Just (SshRemote.CHANGED shas) ->
-					whenM (checkNewShas transporthandle shas) $
-						fetch
-				Nothing -> shutdown
+		send (DISCONNECTED url)
+		hClose toh
+		hClose fromh
+		void $ waitForProcess pid
 
-		-- The only control message that matters is STOP.
-		--
-		-- 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
+		return $ either (either id id) id status
 
-		-- Run both threads until one finishes.
-		void $ tryIO $ concurrently fromshell handlecontrol
-		shutdown
-
-	send msg = writeChan ochan (msg remotename)
+	send msg = writeChan ochan msg
 
 	fetch = do
-		send SYNCING
+		send (SYNCING url)
 		ok <- inLocalRepo transporthandle $
-			runBool [Param "fetch", Param remotename]
-		send (DONESYNCING ok)
+			runBool [Param "fetch", Param $ Git.repoDescribe r]
+		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
+			_ -> 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