webapp: Display any error message from git init if it fails to create a repository.
This commit is contained in:
parent
7dfa97ffaf
commit
9d6fd5b927
6 changed files with 56 additions and 36 deletions
|
@ -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:
|
||||
|
|
|
@ -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 -}
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
2
debian/changelog
vendored
|
@ -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
|
||||
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue