webapp: Encourage user to install git-annex on a server when adding a ssh server, rather than just funneling them through to rsync.

This commit is contained in:
Joey Hess 2013-03-16 12:58:59 -04:00
parent ab0c6db755
commit 996e899acc
6 changed files with 50 additions and 20 deletions

View file

@ -49,6 +49,14 @@ mkSshData s = SshData
, rsyncOnly = False
}
mkSshInput :: SshData -> SshInput
mkSshInput s = SshInput
{ inputHostname = Just $ sshHostName s
, inputUsername = sshUserName s
, inputDirectory = Just $ sshDirectory s
, inputPort = sshPort s
}
sshInputAForm :: (Field WebApp WebApp Text) -> SshInput -> AForm WebApp WebApp SshInput
sshInputAForm hostnamefield def = SshInput
<$> aopt check_hostname "Host name" (Just $ inputHostname def)
@ -104,6 +112,9 @@ getAddSshR = sshConfigurator $ do
where
showform form enctype status = $(widgetFile "configurators/ssh/add")
sshTestModal :: Widget
sshTestModal = $(widgetFile "configurators/ssh/testmodal")
{- To enable an existing rsync special remote, parse the SshInput from
- its rsyncurl, and display a form whose only real purpose is to check
- if ssh public keys need to be set up. From there, we can proceed with
@ -243,6 +254,11 @@ getConfirmSshR :: SshData -> Handler RepHtml
getConfirmSshR sshdata = sshConfigurator $
$(widgetFile "configurators/ssh/confirm")
getRetrySshR :: SshData -> Handler ()
getRetrySshR sshdata = do
s <- liftIO $ testServer $ mkSshInput sshdata
redirect $ either (const $ ConfirmSshR sshdata) ConfirmSshR s
getMakeSshGitR :: SshData -> Handler RepHtml
getMakeSshGitR = makeSsh False setupGroup