Better ssh connection warmup when using -J for concurrency.

Avoids ugly messages when forced ssh command is not git-annex-shell.

This commit was sponsored by Ole-Morten Duesund on Patreon.

5 files changed, 60 insertions, 40 deletions

diff --git a/Annex/Ssh.hs b/Annex/Ssh.hs
index 7280b58a4..b913c154c 100644
--- a/Annex/Ssh.hs
+++ b/Annex/Ssh.hs
@@ -202,36 +202,33 @@ prepSocket socketfile gc sshhost sshparams = do
 	-- the connection has already been started. Otherwise,
 	-- get the connection started now.
 	makeconnection socketlock =
-		whenM (isNothing <$> fromLockCache socketlock) $ do
-			let startps = Param (fromSshHost sshhost) :
-				sshparams ++ startSshConnection gc
-			-- When we can start the connection in batch mode,
-			-- ssh won't prompt to the console.
-			(_, connected) <- liftIO $ processTranscript "ssh"
-				(["-o", "BatchMode=true"]
-				++ toCommand startps)
-				Nothing
-			unless connected $ do
-				ok <- prompt $ liftIO $
-					boolSystem "ssh" startps
-				unless ok $
-					warning $ "Unable to run git-annex-shell on remote " ++
-						Git.repoDescribe (gitConfigRepo (remoteGitConfig gc))
-
--- Parameters to get ssh connected to the remote host,
--- by asking it to run a no-op command.
---
--- Could simply run "true", but the remote host may only
--- allow git-annex-shell to run. So, run git-annex-shell inannex
--- with the path to the remote repository and no other parameters,
--- which is a no-op supported by all versions of git-annex-shell.
-startSshConnection :: RemoteGitConfig -> [CommandParam]
-startSshConnection gc =
-	[ Param "git-annex-shell"
-	, Param "inannex"
-	, File $ Git.repoPath $ gitConfigRepo $
-		remoteGitConfig gc
-	]
+		whenM (isNothing <$> fromLockCache socketlock) $
+			-- See if ssh can connect in batch mode,
+			-- if so there's no need to block for a password
+			-- prompt.
+			unlessM (tryssh ["-o", "BatchMode=true"]) $
+				-- ssh needs to prompt (probably)
+				-- If the user enters the wrong password,
+				-- ssh will tell them, so we can ignore
+				-- failure.
+				void $ prompt $ tryssh []
+	-- Try to ssh to the host quietly. Returns True if ssh apparently
+	-- connected to the host successfully. If ssh failed to connect,
+	-- returns False.
+	-- Even if ssh is forced to run some specific command, this will
+	-- return True.
+	-- (Except there's an unlikely false positive where a forced
+	-- ssh command exits 255.)
+	tryssh extraps = liftIO $ do
+		let p = proc "ssh" $ concat
+			[ extraps
+			, toCommand sshparams
+			, [fromSshHost sshhost, "true"]
+			]
+		(_, exitcode) <- processTranscript'' p Nothing
+		return $ case exitcode of
+			ExitFailure 255 -> False
+			_ -> True
 
 {- Find ssh socket files.
  -
diff --git a/CHANGELOG b/CHANGELOG
index 6ec71de55..1eeea4f02 100644
--- a/CHANGELOG
+++ b/CHANGELOG
@@ -17,6 +17,8 @@ git-annex (6.20180228) UNRELEASED; urgency=medium
     present when locking it. This could cause git annex drop to remove
     the only copy of a file when it thought the tor remote had a copy.
   * git-annex-shell: Added p2pstdio mode.
+  * Better ssh connection warmup when using -J for concurrency.
+    Avoids ugly messages when forced ssh command is not git-annex-shell.
 
  -- Joey Hess <id@joeyh.name>  Wed, 28 Feb 2018 11:53:03 -0400
 
diff --git a/Utility/Process/Transcript.hs b/Utility/Process/Transcript.hs
index 0dbe428f7..0dbbd443a 100644
--- a/Utility/Process/Transcript.hs
+++ b/Utility/Process/Transcript.hs
@@ -1,6 +1,6 @@
 {- Process transcript
  -
- - Copyright 2012-2015 Joey Hess <id@joeyh.name>
+ - Copyright 2012-2018 Joey Hess <id@joeyh.name>
  -
  - License: BSD-2-clause
  -}
@@ -13,6 +13,7 @@ module Utility.Process.Transcript where
 import Utility.Process
 
 import System.IO
+import System.Exit
 import Control.Concurrent
 import qualified Control.Exception as E
 import Control.Monad
@@ -24,14 +25,19 @@ import Control.Applicative
 import Data.Maybe
 import Prelude
 
--- | Runs a process, optionally feeding it some input, and
--- returns a transcript combining its stdout and stderr, and
--- whether it succeeded or failed.
+-- | Runs a process and returns a transcript combining its stdout and
+-- stderr, and whether it succeeded or failed.
 processTranscript :: String -> [String] -> (Maybe String) -> IO (String, Bool)
 processTranscript cmd opts = processTranscript' (proc cmd opts)
 
+-- | Also feeds the process some input.
 processTranscript' :: CreateProcess -> Maybe String -> IO (String, Bool)
 processTranscript' cp input = do
+	(t, c) <- processTranscript'' cp input
+	return (t, c == ExitSuccess)
+
+processTranscript'' :: CreateProcess -> Maybe String -> IO (String, ExitCode)
+processTranscript'' cp input = do
 #ifndef mingw32_HOST_OS
 {- This implementation interleves stdout and stderr in exactly the order
  - the process writes them. -}
@@ -48,9 +54,6 @@ processTranscript' cp input = do
 	get <- mkreader readh
 	writeinput input p
 	transcript <- get
-
-	ok <- checkSuccessProcess pid
-	return (transcript, ok)
 #else
 {- This implementation for Windows puts stderr after stdout. -}
 	p@(_, _, _, pid) <- createProcess $ cp
@@ -63,10 +66,9 @@ processTranscript' cp input = do
 	geterr <- mkreader (stderrHandle p)
 	writeinput input p
 	transcript <- (++) <$> getout <*> geterr
-
-	ok <- checkSuccessProcess pid
-	return (transcript, ok)
 #endif
+	code <- waitForProcess pid
+	return (transcript, code)
   where
 	mkreader h = do
 		s <- hGetContents h
diff --git a/doc/bugs/GIT__95__ANNEX__95__SHELL__95__DIRECTORY_won__39__t_match.mdwn b/doc/bugs/GIT__95__ANNEX__95__SHELL__95__DIRECTORY_won__39__t_match.mdwn
index 1f66c42da..63c8d16c3 100644
--- a/doc/bugs/GIT__95__ANNEX__95__SHELL__95__DIRECTORY_won__39__t_match.mdwn
+++ b/doc/bugs/GIT__95__ANNEX__95__SHELL__95__DIRECTORY_won__39__t_match.mdwn
@@ -30,3 +30,4 @@ git-annex version: 6.20180227-g32d682dd8 (standalone version) on Debian stretch
 As always, I'm a fan :>
 
 
+> [[fixed|done]] --[[Joey]]
diff --git a/doc/bugs/GIT__95__ANNEX__95__SHELL__95__DIRECTORY_won__39__t_match/comment_4_57d694df6c22c42cbdc98ffc5dbc0945._comment b/doc/bugs/GIT__95__ANNEX__95__SHELL__95__DIRECTORY_won__39__t_match/comment_4_57d694df6c22c42cbdc98ffc5dbc0945._comment
new file mode 100644
index 000000000..e344830b0
--- /dev/null
+++ b/doc/bugs/GIT__95__ANNEX__95__SHELL__95__DIRECTORY_won__39__t_match/comment_4_57d694df6c22c42cbdc98ffc5dbc0945._comment
@@ -0,0 +1,18 @@
+[[!comment format=mdwn
+ username="joey"
+ subject="""comment 4"""
+ date="2018-03-07T20:25:10Z"
+ content="""
+Ok, this involves the fairly recently added support for
+avoding overlapping ssh password prompts when running multiple ssh
+processes concurrently.
+
+In -J mode, git-annex warms up the ssh connection by running
+"git-annex-shell inannex". Your rrsync config prevents that being run.
+
+This doesn't actually cause a problem, the connection is still warmed up.
+If you needed a password to connect, it would have prompted for it before
+the error message from rrsync.
+
+But it's ugly.. I've committed a fix that will avoid the ugly messages.
+"""]]