enabling ssh gcrypt now works

This commit is contained in:
Joey Hess 2013-10-01 16:08:01 -04:00
parent 1536ebfe47
commit 5f9f7024e9
3 changed files with 62 additions and 55 deletions

View file

@ -14,13 +14,12 @@ import Assistant.WebApp.Common
import Assistant.WebApp.Gpg
import Assistant.Ssh
import Assistant.MakeRemote
import Utility.Rsync (rsyncUrlIsShell)
import Logs.Remote
import Remote
import Types.StandardGroups
import Utility.UserInfo
import Utility.Gpg
import Types.Remote (RemoteConfigKey)
import Types.Remote (RemoteConfig)
import Git.Remote
import Assistant.WebApp.Utility
import qualified Remote.GCrypt as GCrypt
@ -136,10 +135,11 @@ sshTestModal = $(widgetFile "configurators/ssh/testmodal")
getEnableRsyncR :: UUID -> Handler Html
getEnableRsyncR = postEnableRsyncR
postEnableRsyncR :: UUID -> Handler Html
postEnableRsyncR = enableSpecialSshRemote "rsyncurl" enableRsyncNet enablersync
postEnableRsyncR = enableSpecialSshRemote getsshinput enableRsyncNet enablersync
where
enablersync sshdata = redirect $ ConfirmSshR $
sshdata { sshCapabilities = [RsyncCapable] }
getsshinput = parseSshUrl <=< M.lookup "rsyncurl"
{- This only handles gcrypt repositories that are located on ssh servers;
- ones on local drives are handled via another part of the UI. -}
@ -147,22 +147,23 @@ getEnableGCryptR :: UUID -> Handler Html
getEnableGCryptR = postEnableGCryptR
postEnableGCryptR :: UUID -> Handler Html
postEnableGCryptR u = whenGcryptInstalled $
enableSpecialSshRemote "gitrepo" enableRsyncNetGCrypt enablegcrypt u
enableSpecialSshRemote getsshinput enableRsyncNetGCrypt enablegcrypt u
where
enablegcrypt sshdata = prepSsh True sshdata $ \sshdata' ->
sshConfigurator $
checkExistingGCrypt sshdata' $
error "Expected to find an encrypted git repository, but did not."
getsshinput = parseSshUrl <=< M.lookup "gitrepo"
{- To enable an special remote that uses ssh as its transport,
{- To enable a special remote that uses ssh as its transport,
- parse a config key to get its url, and display a form whose
- only real purpose is to check if ssh public keys need to be
- set up.
-}
enableSpecialSshRemote :: RemoteConfigKey -> (SshInput -> RemoteName -> Handler Html) -> (SshData -> Handler Html) -> UUID -> Handler Html
enableSpecialSshRemote urlkey rsyncnetsetup genericsetup u = do
enableSpecialSshRemote :: (RemoteConfig -> Maybe SshData) -> (SshInput -> RemoteName -> Handler Html) -> (SshData -> Handler Html) -> UUID -> Handler Html
enableSpecialSshRemote getsshinput rsyncnetsetup genericsetup u = do
m <- fromMaybe M.empty . M.lookup u <$> liftAnnex readRemoteLog
case (parseSshRsyncUrl =<< M.lookup urlkey m, M.lookup "name" m) of
case (mkSshInput . unmangle <$> getsshinput m, M.lookup "name" m) of
(Just sshinput, Just reponame) -> sshConfigurator $ do
((result, form), enctype) <- liftH $
runFormPost $ renderBootstrap $ sshInputAForm textField sshinput
@ -179,33 +180,14 @@ enableSpecialSshRemote urlkey rsyncnetsetup genericsetup u = do
_ -> showform form enctype UntestedServer
_ -> redirect AddSshR
where
unmangle sshdata = sshdata
{ sshHostName = T.pack $ unMangleSshHostName $
T.unpack $ sshHostName sshdata
}
showform form enctype status = do
description <- liftAnnex $ T.pack <$> prettyUUID u
$(widgetFile "configurators/ssh/enable")
{- Converts a rsyncurl value to a SshInput. But only if it's a ssh rsync
- url; rsync:// urls or bare path names are not supported.
-
- The hostname is stored mangled in the remote log for rsync special
- remotes configured by this webapp. So that mangling has to reversed
- here to get back the original hostname.
-}
parseSshRsyncUrl :: String -> Maybe SshInput
parseSshRsyncUrl u
| not (rsyncUrlIsShell u) = Nothing
| otherwise = Just $ SshInput
{ inputHostname = val $ unMangleSshHostName host
, inputUsername = if null user then Nothing else val user
, inputDirectory = val dir
, inputPort = 22
}
where
val = Just . T.pack
(userhost, dir) = separate (== ':') u
(user, host) = if '@' `elem` userhost
then separate (== '@') userhost
else (userhost, "")
{- Test if we can ssh into the server.
-
- Two probe attempts are made. First, try sshing in using the existing
@ -331,14 +313,14 @@ checkExistingGCrypt sshdata nope = ifM (liftIO isGcryptInstalled)
, nope
)
where
repourl = sshUrl sshdata
repourl = genSshUrl sshdata
{- Enables an existing gcrypt special remote. -}
enableGCrypt :: SshData -> RemoteName -> Handler Html
enableGCrypt sshdata reponame =
setupCloudRemote TransferGroup Nothing $
enableSpecialRemote reponame GCrypt.remote $ M.fromList
[("gitrepo", sshUrl sshdata)]
[("gitrepo", genSshUrl sshdata)]
{- Sets up remote repository for ssh, or directory for rsync. -}
prepSsh :: Bool -> SshData -> (SshData -> Handler Html) -> Handler Html
@ -375,7 +357,7 @@ makeSshRepo sshdata = setupCloudRemote TransferGroup Nothing $
makeGCryptRepo :: KeyId -> SshData -> Handler Html
makeGCryptRepo keyid sshdata = setupCloudRemote TransferGroup Nothing $
makeGCryptRemote (sshRepoName sshdata) (sshUrl sshdata) keyid
makeGCryptRemote (sshRepoName sshdata) (genSshUrl sshdata) keyid
getAddRsyncNetR :: Handler Html
getAddRsyncNetR = postAddRsyncNetR
@ -434,7 +416,7 @@ enableRsyncNet sshinput reponame =
enableRsyncNetGCrypt :: SshInput -> RemoteName -> Handler Html
enableRsyncNetGCrypt sshinput reponame =
prepRsyncNet sshinput reponame $ \sshdata ->
checkGCryptRepoEncryption (sshUrl sshdata) notencrypted $
checkGCryptRepoEncryption (genSshUrl sshdata) notencrypted $
enableGCrypt sshdata reponame
where
notencrypted = error "Unexpectedly found a non-encrypted git repository, instead of the expected encrypted git repository."