webapp: Display any error message from git init if it fails to create a repository.

4 files changed, 51 insertions, 32 deletions

diff --git a/Assistant/Pairing/MakeRemote.hs b/Assistant/Pairing/MakeRemote.hs
index f938bac93..24a83b43c 100644
--- a/Assistant/Pairing/MakeRemote.hs
+++ b/Assistant/Pairing/MakeRemote.hs
@@ -41,7 +41,7 @@ finishedLocalPairing msg keypair = do
 			, genSshHost (sshHostName sshdata) (sshUserName sshdata)
 			, "git-annex-shell -c configlist " ++ T.unpack (sshDirectory sshdata)
 			]
-			""
+			Nothing
 	void $ makeSshRemote False sshdata
 
 {- Mostly a straightforward conversion.  Except:
diff --git a/Assistant/Ssh.hs b/Assistant/Ssh.hs
index 753babad4..93d567ce4 100644
--- a/Assistant/Ssh.hs
+++ b/Assistant/Ssh.hs
@@ -61,36 +61,8 @@ genSshRepoName host dir
 	| otherwise = makeLegalName $ host ++ "_" ++ dir
 
 {- The output of ssh, including both stdout and stderr. -}
-sshTranscript :: [String] -> String -> IO (String, Bool)
-sshTranscript opts input = do
-	(readf, writef) <- createPipe
-	readh <- fdToHandle readf
-	writeh <- fdToHandle writef
-	(Just inh, _, _, pid) <- createProcess $
-		(proc "ssh" opts)
-			{ std_in = CreatePipe
-			, std_out = UseHandle writeh
-			, std_err = UseHandle writeh
-			}
-	hClose writeh
-
-	-- fork off a thread to start consuming the output
-	transcript <- hGetContents readh
-	outMVar <- newEmptyMVar
-	_ <- forkIO $ E.evaluate (length transcript) >> putMVar outMVar ()
-
-	-- now write and flush any input
-	unless (null input) $ do
-		hPutStr inh input
-		hFlush inh
-	hClose inh -- done with stdin
-
-	-- wait on the output
-	takeMVar outMVar
-	hClose readh
-
-	ok <- checkSuccessProcess pid
-	return (transcript, ok)
+sshTranscript :: [String] -> (Maybe String) -> IO (String, Bool)
+sshTranscript opts input = processTranscript "ssh" opts input
 
 {- Ensure that the ssh public key doesn't include any ssh options, like
  - command=foo, or other weirdness -}
diff --git a/Utility/Process.hs b/Utility/Process.hs
index 11a9a4f38..b2bac99a1 100644
--- a/Utility/Process.hs
+++ b/Utility/Process.hs
@@ -21,6 +21,7 @@ module Utility.Process (
 	createProcessSuccess,
 	createProcessChecked,
 	createBackgroundProcess,
+	processTranscript,
 	withHandle,
 	withBothHandles,
 	withQuietOutput,
@@ -40,6 +41,8 @@ import System.Log.Logger
 import Control.Concurrent
 import qualified Control.Exception as E
 import Control.Monad
+import Data.Maybe
+import System.Posix.IO
 
 import Utility.Misc
 
@@ -116,7 +119,10 @@ forceSuccessProcess p pid = do
 		ExitSuccess -> return ()
 		ExitFailure n -> fail $ showCmd p ++ " exited " ++ show n
 
-{- Waits for a ProcessHandle and returns True if it exited successfully. -}
+{- Waits for a ProcessHandle and returns True if it exited successfully.
+ - Note that using this with createProcessChecked will throw away
+ - the Bool, and is only useful to ignore the exit code of a process,
+ - while still waiting for it. -}
 checkSuccessProcess :: ProcessHandle -> IO Bool
 checkSuccessProcess pid = do
 	code <- waitForProcess pid
@@ -146,6 +152,45 @@ createProcessChecked checker p a = do
 createBackgroundProcess :: CreateProcessRunner
 createBackgroundProcess p a = a =<< createProcess p
 
+{- Runs a process, optionally feeding it some input, 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 input = do
+	(readf, writef) <- createPipe
+	readh <- fdToHandle readf
+	writeh <- fdToHandle writef
+	p@(_, _, _, pid) <- createProcess $
+		(proc cmd opts)
+			{ std_in = if isJust input then CreatePipe else Inherit
+			, std_out = UseHandle writeh
+			, std_err = UseHandle writeh
+			}
+	hClose writeh
+
+	-- fork off a thread to start consuming the output
+	transcript <- hGetContents readh
+	outMVar <- newEmptyMVar
+	_ <- forkIO $ E.evaluate (length transcript) >> putMVar outMVar ()
+
+	-- now write and flush any input
+	case input of
+		Just s -> do
+			let inh = stdinHandle p
+			unless (null s) $ do
+				hPutStr inh s
+				hFlush inh
+			hClose inh
+		Nothing -> return ()
+
+	-- wait on the output
+	takeMVar outMVar
+	hClose readh
+
+	ok <- checkSuccessProcess pid
+	return (transcript, ok)
+
+
 {- Runs a CreateProcessRunner, on a CreateProcess structure, that
  - is adjusted to pipe only from/to a single StdHandle, and passes
  - the resulting Handle to an action. -}
diff --git a/debian/changelog b/debian/changelog
index d3e7a0544..cb384bc6e 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -14,6 +14,8 @@ git-annex (3.20130217) UNRELEASED; urgency=low
   * Direct mode: Fix support for adding a modified file.
   * Avoid passing -p to rsync, to interoperate with crippled filesystems.
   * Additional GIT_DIR support bugfixes. May actually work now.
+  * webapp: Display any error message from git init if it fails to create
+    a repository.
 
  -- Joey Hess <joeyh@debian.org>  Sun, 17 Feb 2013 16:42:16 -0400