mirrors/git-annex
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages 1 Wiki Activity Actions

wip

Browse source
This commit is contained in:
Joey Hess 2014-04-30 21:27:17 -04:00
parent 315daa9993
commit 44b6d6c5e0
1 changed files with 22 additions and 16 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

38
Assistant/WebApp/Configurators/Ssh.hs
View file

@ -1,6 +1,6 @@
{- git-annex assistant webapp configurator for ssh-based remotes {- git-annex assistant webapp configurator for ssh-based remotes
- -
- Copyright 2012-2013 Joey Hess <joey@kitenet.net> - Copyright 2012-2014 Joey Hess <joey@kitenet.net>
- -
- Licensed under the GNU AGPL version 3 or higher. - Licensed under the GNU AGPL version 3 or higher.
-} -}
@ -125,8 +125,9 @@ postAddSshR = sshConfigurator $ do
SshInput Nothing (Just username) Nothing 22 SshInput Nothing (Just username) Nothing 22
case result of case result of
FormSuccess sshinput -> do FormSuccess sshinput -> do
s <- liftIO $ testServer sshinput s <- liftIO $ testServer NoPassword sshinput
case s of case s of
-- XXX FIXME: now what???
Left status -> showform form enctype status Left status -> showform form enctype status
Right (sshdata, u) -> liftH $ redirect $ ConfirmSshR sshdata u Right (sshdata, u) -> liftH $ redirect $ ConfirmSshR sshdata u
_ -> showform form enctype UntestedServer _ -> showform form enctype UntestedServer
@ -205,12 +206,18 @@ wrapCommand cmd = "if [ -x " ++ commandWrapper ++ " ]; then " ++ commandWrapper
commandWrapper :: String commandWrapper :: String
commandWrapper = "~/.ssh/git-annex-wrapper" commandWrapper = "~/.ssh/git-annex-wrapper"
data UsePassword
= NoPassword
| CachedPassword
deriving (Eq)
{- Test if we can ssh into the server. {- Test if we can ssh into the server.
- -
- Two probe attempts are made. First, try sshing in using the existing - To detect if passwordless login is already enabled on the server,
- configuration, but don't let ssh prompt for any password. If - pass NoPassword.
- passwordless login is already enabled, use it. Otherwise, -
- a special ssh key will need to be generated just for this server. - If that fails, the caller should prompt the user for the necessary
- password, and retry with CachedPassword.
- -
- Once logged into the server, probe to see if git-annex-shell, - Once logged into the server, probe to see if git-annex-shell,
- git, and rsync are available. - git, and rsync are available.
@ -223,18 +230,17 @@ commandWrapper = "~/.ssh/git-annex-wrapper"
- Also probe to see if there is already a git repository at the location - Also probe to see if there is already a git repository at the location
- with either an annex-uuid or a gcrypt-id set. (If not, returns NoUUID.) - with either an annex-uuid or a gcrypt-id set. (If not, returns NoUUID.)
-} -}
testServer :: SshInput -> IO (Either ServerStatus (SshData, UUID)) testServer :: UsePassword -> SshInput -> IO (Either ServerStatus (SshData, UUID))
testServer (SshInput { inputHostname = Nothing }) = return $ testServer _ (SshInput { inputHostname = Nothing }) = return $
Left $ UnusableServer "Please enter a host name." Left $ UnusableServer "Please enter a host name."
testServer sshinput@(SshInput { inputHostname = Just hn }) = do testServer usepassword sshinput@(SshInput { inputHostname = Just hn }) = do
(status, u) <- probe [sshOpt "NumberOfPasswordPrompts" "0"] (status, u) <- probe $
if usepassword == NoPassword
then [sshOpt "NumberOfPasswordPrompts" "0"]
else []
case capabilities status of case capabilities status of
[] -> do [] -> return $ Left status'
(status', u') <- probe [] cs -> ret cs (usepassword == CachedPassword) u
case capabilities status' of
[] -> return $ Left status'
cs -> ret cs True u'
cs -> ret cs False u
where where
ret cs needspubkey u = do ret cs needspubkey u = do
let sshdata = (mkSshData sshinput) let sshdata = (mkSshData sshinput)