Merge branch 'winprocfix'

Assistant/WebApp/Configurators/Ssh.hs

@@ -366,12 +366,6 @@ sshErr sshinput msg
  - Depending on the SshInput, avoids using a password, or uses a
  - cached password. ssh is coaxed to use git-annex as SSH_ASKPASS
  - to get the password.
- -
- - Note that ssh will only use SSH_ASKPASS when DISPLAY is set and there
- - is no controlling terminal. On Unix, that is set up when the assistant
- - starts, by calling createSession. On Windows, all of stdin, stdout, and
- - stderr must be disconnected from the terminal. This is accomplished
- - by always providing input on stdin.
  -}
 sshAuthTranscript :: SshInput -> [String] -> (Maybe String) -> Assistant (String, Bool)
 sshAuthTranscript sshinput opts input = case inputAuthMethod sshinput of
@@ -384,8 +378,20 @@ sshAuthTranscript sshinput opts input = case inputAuthMethod sshinput of
 	login = getLogin sshinput
 	geti f = maybe "" T.unpack (f sshinput)
 
-	go extraopts environ = processTranscript' "ssh" (extraopts ++ opts) environ $
+	go extraopts environ = processTranscript' 
-		Just (fromMaybe "" input)
+		(askPass environ) "ssh" (extraopts ++ opts)
+		-- Always provide stdin, even when empty.
+		(Just (fromMaybe "" input))
+
+ 	{- ssh will only use SSH_ASKPASS when DISPLAY is set and there
+	 - is no controlling terminal. -}
+	askPass environ p = p
+		{ env = environ
+#if MIN_VERSION_process(1,3,0)
+		, detach_console = True
+		, new_session = True
+#endif
+		}
 
 	setupAskPass = do
 		program <- liftIO programPath
@@ -399,10 +405,6 @@ sshAuthTranscript sshinput opts input = case inputAuthMethod sshinput of
 				let environ' = addEntries
 					[ ("SSH_ASKPASS", program)
 					, (sshAskPassEnv, passfile)
-					-- ssh does not use SSH_ASKPASS
-					-- unless DISPLAY is set, and
-					-- there is no controlling
-					-- terminal.
 					, ("DISPLAY", ":0")
 					] environ
 				go [passwordprompts 1] (Just environ')

Build/EvilLinker.hs

@@ -21,6 +21,7 @@ import Data.List
 
 import Utility.Monad
 import Utility.Process hiding (env)
+import qualified Utility.Process
 import Utility.Env
 
 data CmdParams = CmdParams
@@ -126,7 +127,7 @@ getOutput c ps environ = do
 	putStrLn $ unwords [c, show ps]
 	systemenviron <- getEnvironment
 	let environ' = fromMaybe [] environ ++ systemenviron
-	out@(_, ok) <- processTranscript' c ps (Just environ') Nothing
+	out@(_, ok) <- processTranscript' (\p -> p { Utility.Process.env = Just environ' }) c ps Nothing
 	putStrLn $ unwords [c, "finished", show ok]
 	return out
 

Utility/Process.hs

@@ -172,22 +172,21 @@ createBackgroundProcess p a = a =<< createProcess p
 -- 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' cmd opts Nothing
+processTranscript = processTranscript' id
 
-processTranscript' :: String -> [String] -> Maybe [(String, String)] -> (Maybe String) -> IO (String, Bool)
+processTranscript' :: (CreateProcess -> CreateProcess) -> String -> [String] -> Maybe String -> IO (String, Bool)
-processTranscript' cmd opts environ input = do
+processTranscript' modproc cmd opts input = do
 #ifndef mingw32_HOST_OS
 {- This implementation interleves stdout and stderr in exactly the order
  - the process writes them. -}
 	(readf, writef) <- System.Posix.IO.createPipe
 	readh <- System.Posix.IO.fdToHandle readf
 	writeh <- System.Posix.IO.fdToHandle writef
-	p@(_, _, _, pid) <- createProcess $
+	p@(_, _, _, pid) <- createProcess $ modproc $
 		(proc cmd opts)
 			{ std_in = if isJust input then CreatePipe else Inherit
 			, std_out = UseHandle writeh
 			, std_err = UseHandle writeh
-			, env = environ
 			}
 	hClose writeh
 
@@ -199,12 +198,11 @@ processTranscript' cmd opts environ input = do
 	return (transcript, ok)
 #else
 {- This implementation for Windows puts stderr after stdout. -}
-	p@(_, _, _, pid) <- createProcess $
+	p@(_, _, _, pid) <- createProcess $ modproc $
 		(proc cmd opts)
 			{ std_in = if isJust input then CreatePipe else Inherit
 			, std_out = CreatePipe
 			, std_err = CreatePipe
-			, env = environ
 			}
 
 	getout <- mkreader (stdoutHandle p)

debian/changelog

@@ -11,6 +11,8 @@ git-annex (5.20150931) UNRELEASED; urgency=medium
     setting annex.verify=false.
   * Allow building with S3 disabled again.
   * Ported disk free space checking code to work on Solaris.
+  * Windows webapp: Fix support for entering password when setting
+    up a ssh remote.
 
  -- Joey Hess <id@joeyh.name>  Thu, 01 Oct 2015 12:42:56 -0400
 

doc/bugs/windows_ssh_webapp_password_entry_broken.mdwn

@@ -7,3 +7,5 @@ set up a passwordless ssh key that can log into the ssh server. --[[Joey]]
 > I have a `winprocfix` branch that uses process-1.3 which has been
 > enhanced to allow fixing this. Merging is currently blocked on
 > <https://github.com/pcapriotti/optparse-applicative/issues/153> --[[Joey]]
+> 
+> [[fixed|done]] --[[Joey]]

git-annex.cabal

@@ -157,7 +157,8 @@ Executable git-annex
     GHC-Options: -O2
 
   if (os(windows))
-    Build-Depends: Win32, Win32-extras, unix-compat (>= 0.4.1.3), setenv
+    Build-Depends: Win32, Win32-extras, unix-compat (>= 0.4.1.3), setenv,
+      process (>= 1.3.0.0)
   else
     Build-Depends: unix
     -- Need to list these because they're generated from .hsc files.