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

This commit is contained in:
Joey Hess 2013-02-26 13:04:37 -04:00
parent 7dfa97ffaf
commit 9d6fd5b927
6 changed files with 56 additions and 36 deletions

View file

@ -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:

View file

@ -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 -}

View file

@ -276,8 +276,9 @@ startFullAssistant path = do
{- Makes a new git repository. -}
makeRepo :: FilePath -> Bool -> IO ()
makeRepo path bare = do
unlessM (boolSystem "git" params) $
error "git init failed!"
(transcript, ok) <- processTranscript "git" (toCommand params) Nothing
unless ok $
error $ "git init failed!\nOutput:\n" ++ transcript
where
baseparams = [Param "init", Param "--quiet"]
params

View file

@ -210,7 +210,7 @@ testServer sshinput@(SshInput { inputHostname = Just hn }) = do
(inputUsername sshinput)
, remotecommand
]
parsetranscript . fst <$> sshTranscript sshopts ""
parsetranscript . fst <$> sshTranscript sshopts Nothing
parsetranscript s
| reported "git-annex-shell" = UsableSshInput
| reported shim = UsableSshInput
@ -230,7 +230,7 @@ testServer sshinput@(SshInput { inputHostname = Just hn }) = do
- and if it succeeds, runs an action. -}
sshSetup :: [String] -> String -> Handler RepHtml -> Handler RepHtml
sshSetup opts input a = do
(transcript, ok) <- liftIO $ sshTranscript opts input
(transcript, ok) <- liftIO $ sshTranscript opts (Just input)
if ok
then a
else showSshErr transcript

View file

@ -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. -}

2
debian/changelog vendored
View file

@ -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