Ssh password prompting improved when using -J

When ssh connection caching is enabled (and when GIT_ANNEX_USE_GIT_SSH is
not set), only one ssh password prompt will be made per host, and only one
ssh password prompt will be made at a time.

This also fixes a race in prepSocket's stale ssh connection stopping
when run with -J. It was possible for one thread to start a cached ssh
connection, and another thread to immediately stop it, resulting in excess
connections being made.

This commit was supported by the NSF-funded DataLad project.

8 files changed, 104 insertions, 36 deletions

diff --git a/Annex.hs b/Annex.hs
index 2a372f158..3c47789b5 100644
--- a/Annex.hs
+++ b/Annex.hs
@@ -124,6 +124,7 @@ data AnnexState = AnnexState
 	, groupmap :: Maybe GroupMap
 	, ciphers :: M.Map StorableCipher Cipher
 	, lockcache :: LockCache
+	, sshstalecleaned :: MVar ()
 	, flags :: M.Map String Bool
 	, fields :: M.Map String String
 	, cleanup :: M.Map CleanupAction (Annex ())
@@ -145,6 +146,8 @@ data AnnexState = AnnexState
 newState :: GitConfig -> Git.Repo -> IO AnnexState
 newState c r = do
 	emptyactiveremotes <- newMVar M.empty
+	o <- newMessageState
+	sc <- newMVar ()
 	return $ AnnexState
 		{ repo = r
 		, repoadjustment = return
@@ -152,7 +155,7 @@ newState c r = do
 		, backend = Nothing
 		, remotes = []
 		, remoteannexstate = M.empty
-		, output = def
+		, output = o
 		, concurrency = NonConcurrent
 		, force = False
 		, fast = False
@@ -175,6 +178,7 @@ newState c r = do
 		, groupmap = Nothing
 		, ciphers = M.empty
 		, lockcache = M.empty
+		, sshstalecleaned = sc
 		, flags = M.empty
 		, fields = M.empty
 		, cleanup = M.empty
diff --git a/Annex/LockFile.hs b/Annex/LockFile.hs
index cb1d232b9..1f35444f5 100644
--- a/Annex/LockFile.hs
+++ b/Annex/LockFile.hs
@@ -11,6 +11,7 @@ module Annex.LockFile (
 	lockFileCached,
 	unlockFile,
 	getLockCache,
+	fromLockCache,
 	withExclusiveLock,
 	tryExclusiveLock,
 ) where
diff --git a/Annex/Ssh.hs b/Annex/Ssh.hs
index ae14a560f..09df67666 100644
--- a/Annex/Ssh.hs
+++ b/Annex/Ssh.hs
@@ -23,10 +23,6 @@ module Annex.Ssh (
 	runSshAskPass
 ) where
 
-import qualified Data.Map as M
-import Data.Hash.MD5
-import System.Exit
-
 import Annex.Common
 import Annex.LockFile
 import qualified Build.SysConfig as SysConfig
@@ -38,6 +34,7 @@ import Annex.Path
 import Utility.Env
 import Utility.FileSystemEncoding
 import Types.CleanupActions
+import Types.Messages
 import Git.Env
 import Git.Ssh
 #ifndef mingw32_HOST_OS
@@ -45,6 +42,9 @@ import Annex.Perms
 import Annex.LockPool
 #endif
 
+import Data.Hash.MD5
+import Control.Concurrent
+
 {- Some ssh commands are fed stdin on a pipe and so should be allowed to
  - consume it. But ssh commands that are not piped stdin should generally
  - not be allowed to consume the process's stdin. -}
@@ -71,16 +71,18 @@ sshCommand cs (host, port) gc remotecmd = ifM (liftIO safe_GIT_SSH)
 sshOptions :: ConsumeStdin -> (String, Maybe Integer) -> RemoteGitConfig -> [CommandParam] -> Annex [CommandParam]
 sshOptions cs (host, port) gc opts = go =<< sshCachingInfo (host, port)
   where
-	go (Nothing, params) = ret params
+	go (Nothing, params) = return $ mkparams cs params
 	go (Just socketfile, params) = do
-		prepSocket socketfile
-		ret params
-	ret ps = return $ concat
+		prepSocket socketfile gc
+			(Param host : mkparams NoConsumeStdin params)
+			
+		return $ mkparams cs params
+	mkparams cs' ps = concat
 		[ ps
 		, map Param (remoteAnnexSshOptions gc)
 		, opts
 		, portParams port
-		, consumeStdinParams cs
+		, consumeStdinParams cs'
 		, [Param "-T"]
 		]
 
@@ -158,21 +160,52 @@ portParams :: Maybe Integer -> [CommandParam]
 portParams Nothing = []
 portParams (Just port) = [Param "-p", Param $ show port]
 
-{- Prepare to use a socket file for ssh connection caching. 
- - Locks a lock file to prevent other git-annex processes from
- - stopping the ssh multiplexer on this socket. -}
-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
+{- Prepare to use a socket file for ssh connection caching.
+ -
+ - When concurrency is enabled, this blocks until a ssh connection
+ - has been made to the host. So, any password prompting by ssh will
+ - happen in this call, and only one ssh process will prompt at a time.
+ -
+ - Locks the socket lock file to prevent other git-annex processes from
+ - stopping the ssh multiplexer on this socket.
+ -}
+prepSocket :: FilePath -> RemoteGitConfig -> [CommandParam] -> Annex ()
+prepSocket socketfile gc sshparams = do
+	-- There could be stale ssh connections hanging around
 	-- from a previous git-annex run that was interrupted.
-	whenM (not . any isLock . M.keys <$> getLockCache)
+	-- This must run only once, before we have made any ssh connection.
+	whenM (isJust <$> (liftIO . tryTakeMVar =<< Annex.getState Annex.sshstalecleaned)) $
 		sshCleanup
-	-- Cleanup at end of this run.
+	-- Cleanup at shutdown.
 	Annex.addCleanup SshCachingCleanup sshCleanup
-
+	
 	liftIO $ createDirectoryIfMissing True $ parentDir socketfile
-	lockFileCached $ socket2lock socketfile
+	let socketlock = socket2lock socketfile
+
+	prompt $ \s -> when (concurrentOutputEnabled s) $
+		-- If the LockCache already has the socketlock in it,
+		-- the connection has already been started. Otherwise,
+		-- get the connection started now.
+		whenM (isNothing <$> fromLockCache socketlock) $
+			void $ liftIO $ boolSystem "ssh" $
+				sshparams ++ startSshConnection gc
+	
+	lockFileCached socketlock
+
+-- 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
+	]
 
 {- Find ssh socket files.
  -
@@ -324,12 +357,20 @@ sshOptionsTo remote gc localr
 		Just host -> ifM (liftIO $ safe_GIT_SSH <&&> gitSshEnvSet)
 			( unchanged
 			, do
-				(msockfile, _) <- sshCachingInfo (host, Git.Url.port remote)
+				let port = Git.Url.port remote
+				(msockfile, cacheparams) <- sshCachingInfo (host, port)
 				case msockfile of
 					Nothing -> use []
 					Just sockfile -> do
-						prepSocket sockfile
-						use (sshConnectionCachingParams sockfile)
+						prepSocket sockfile gc $
+							Param host : concat
+								[ cacheparams
+								, map Param (remoteAnnexSshOptions gc)
+								, portParams port
+								, consumeStdinParams NoConsumeStdin
+								, [Param "-T"]
+								]
+						use cacheparams
 			)
   where
 	unchanged = return localr
diff --git a/CHANGELOG b/CHANGELOG
index e6b6d4591..8edf324de 100644
--- a/CHANGELOG
+++ b/CHANGELOG
@@ -1,3 +1,12 @@
+git-annex (6.20170511) UNRELEASED; urgency=medium
+
+  * Ssh password prompting improved when using -J for concurrency.
+    When ssh connection caching is enabled (and when GIT_ANNEX_USE_GIT_SSH
+    is not set), only one ssh password prompt will be made per host, and
+    only one ssh password prompt will be made at a time.
+
+ -- Joey Hess <id@joeyh.name>  Thu, 11 May 2017 15:16:23 -0400
+
 git-annex (6.20170510) unstable; urgency=medium
 
   * When a http remote does not expose an annex.uuid config, only warn
diff --git a/Messages.hs b/Messages.hs
index 0036e5759..f3c44aebf 100644
--- a/Messages.hs
+++ b/Messages.hs
@@ -1,6 +1,6 @@
 {- git-annex output messages
  -
- - Copyright 2010-2016 Joey Hess <id@joeyh.name>
+ - Copyright 2010-2017 Joey Hess <id@joeyh.name>
  -
  - Licensed under the GNU GPL version 3 or higher.
  -}
@@ -41,12 +41,14 @@ module Messages (
 	outputMessage,
 	implicitMessage,
 	withMessageState,
+	prompt,
 ) where
 
 import System.Log.Logger
 import System.Log.Formatter
 import System.Log.Handler (setFormatter)
 import System.Log.Handler.Simple
+import Control.Concurrent
 
 import Common
 import Types
@@ -219,3 +221,15 @@ commandProgressDisabled = withMessageState $ \s -> return $
  - output. -}
 implicitMessage :: Annex () -> Annex ()
 implicitMessage = whenM (implicitMessages <$> Annex.getState Annex.output)
+
+{- Prevents any concurrent console access while running an action, so
+ - that the action is the only thing using the console, and can eg prompt
+ - the user.
+ -}
+prompt :: (MessageState -> Annex a) -> Annex a
+prompt a = withMessageState $ \s ->
+	if concurrentOutputEnabled s
+		then 
+			let l = promptLock s
+			in bracketIO (takeMVar l) (putMVar l) (const (a s))
+		else a s
diff --git a/Messages/Internal.hs b/Messages/Internal.hs
index 7ea8ee067..6ec72812a 100644
--- a/Messages/Internal.hs
+++ b/Messages/Internal.hs
@@ -13,7 +13,6 @@ import Types.Messages
 import Messages.Concurrent
 import Messages.JSON
 
-
 withMessageState :: (MessageState -> Annex a) -> Annex a
 withMessageState a = Annex.getState Annex.output >>= a
 
diff --git a/Types/Messages.hs b/Types/Messages.hs
index 751a513d6..551531349 100644
--- a/Types/Messages.hs
+++ b/Types/Messages.hs
@@ -1,6 +1,6 @@
 {- git-annex Messages data types
  - 
- - Copyright 2012 Joey Hess <id@joeyh.name>
+ - Copyright 2012-2017 Joey Hess <id@joeyh.name>
  -
  - Licensed under the GNU GPL version 3 or higher.
  -}
@@ -9,9 +9,9 @@
 
 module Types.Messages where
 
-import Data.Default
 import qualified Data.Aeson as Aeson
 
+import Control.Concurrent
 #ifdef WITH_CONCURRENTOUTPUT
 import System.Console.Regions (ConsoleRegion)
 #endif
@@ -32,11 +32,13 @@ data MessageState = MessageState
 	, consoleRegionErrFlag :: Bool
 #endif
 	, jsonBuffer :: Maybe Aeson.Object
+	, promptLock :: MVar () -- left full when not prompting
 	}
 
-instance Default MessageState
-  where
-	def = MessageState
+newMessageState :: IO MessageState
+newMessageState = do
+	promptlock <- newMVar ()
+	return $ MessageState
 		{ outputType = NormalOutput
 		, concurrentOutputEnabled = False
 		, sideActionBlock = NoBlock
@@ -46,4 +48,5 @@ instance Default MessageState
 		, consoleRegionErrFlag = False
 #endif
 		, jsonBuffer = Nothing
+		, promptLock = promptlock
 		}
diff --git a/doc/bugs/get_-J_cannot_be_used_with_password-based_authentication/comment_6_f5fe8d4cecfceec5cb4a03dd054d2e0a._comment b/doc/bugs/get_-J_cannot_be_used_with_password-based_authentication/comment_6_f5fe8d4cecfceec5cb4a03dd054d2e0a._comment
index cd692ca40..2daef8727 100644
--- a/doc/bugs/get_-J_cannot_be_used_with_password-based_authentication/comment_6_f5fe8d4cecfceec5cb4a03dd054d2e0a._comment
+++ b/doc/bugs/get_-J_cannot_be_used_with_password-based_authentication/comment_6_f5fe8d4cecfceec5cb4a03dd054d2e0a._comment
@@ -37,9 +37,6 @@ non-concurrent uses the current, faster path.
 prepSocket takes a shared 
 file level lock of the socket's lock file, which is used to tell when
 another git-annex process is using the connection multiplexer.
-So, an optimisation would be for prepSocket to try to take a non-blocking
-exclusive file-level lock. If it fails, it knows some process has
-already taken the shared lock, and so the multiplexer is started and no
-password prompting needs to be done. So it does not need to try to start
-the multiplexer in this case.
+So, an optimisation would be for prepSocket to check if it's already
+taken that shared lock, and then it does not need to start the multiplexer.
 """]]