diff --git a/Assistant/MakeRemote.hs b/Assistant/MakeRemote.hs index d85bf0fd7c..32a3fd6f52 100644 --- a/Assistant/MakeRemote.hs +++ b/Assistant/MakeRemote.hs @@ -24,34 +24,16 @@ import Creds import Assistant.Gpg import Utility.Gpg (KeyId) -import qualified Data.Text as T import qualified Data.Map as M {- Sets up a new git or rsync remote, accessed over ssh. -} makeSshRemote :: SshData -> Annex RemoteName -makeSshRemote sshdata = maker (sshRepoName sshdata) (sshUrl sshdata) +makeSshRemote sshdata = maker (sshRepoName sshdata) (genSshUrl sshdata) where maker | onlyCapability sshdata RsyncCapable = makeRsyncRemote | otherwise = makeGitRemote -{- Generates a ssh or rsync url from a SshData. -} -sshUrl :: SshData -> String -sshUrl sshdata = addtrailingslash $ T.unpack $ T.concat $ - if (onlyCapability sshdata RsyncCapable) - then [u, h, T.pack ":", sshDirectory sshdata] - else [T.pack "ssh://", u, h, d] - where - u = maybe (T.pack "") (\v -> T.concat [v, T.pack "@"]) $ sshUserName sshdata - h = sshHostName sshdata - d - | T.pack "/" `T.isPrefixOf` sshDirectory sshdata = sshDirectory sshdata - | T.pack "~/" `T.isPrefixOf` sshDirectory sshdata = T.concat [T.pack "/", sshDirectory sshdata] - | otherwise = T.concat [T.pack "/~/", sshDirectory sshdata] - addtrailingslash s - | "/" `isSuffixOf` s = s - | otherwise = s ++ "/" - {- Runs an action that returns a name of the remote, and finishes adding it. -} addRemote :: Annex RemoteName -> Annex Remote addRemote a = do diff --git a/Assistant/Ssh.hs b/Assistant/Ssh.hs index c6514e6130..f316aa5008 100644 --- a/Assistant/Ssh.hs +++ b/Assistant/Ssh.hs @@ -1,6 +1,6 @@ {- git-annex assistant ssh utilities - - - Copyright 2012 Joey Hess + - Copyright 2012-2013 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} @@ -11,6 +11,7 @@ import Common.Annex import Utility.Tmp import Utility.UserInfo import Utility.Shell +import Utility.Rsync import Git.Remote import Data.Text (Text) @@ -61,6 +62,48 @@ sshDir = do genSshHost :: Text -> Maybe Text -> String genSshHost host user = maybe "" (\v -> T.unpack v ++ "@") user ++ T.unpack host +{- Generates a ssh or rsync url from a SshData. -} +genSshUrl :: SshData -> String +genSshUrl sshdata = addtrailingslash $ T.unpack $ T.concat $ + if (onlyCapability sshdata RsyncCapable) + then [u, h, T.pack ":", sshDirectory sshdata] + else [T.pack "ssh://", u, h, d] + where + u = maybe (T.pack "") (\v -> T.concat [v, T.pack "@"]) $ sshUserName sshdata + h = sshHostName sshdata + d + | T.pack "/" `T.isPrefixOf` sshDirectory sshdata = sshDirectory sshdata + | T.pack "~/" `T.isPrefixOf` sshDirectory sshdata = T.concat [T.pack "/", sshDirectory sshdata] + | otherwise = T.concat [T.pack "/~/", sshDirectory sshdata] + addtrailingslash s + | "/" `isSuffixOf` s = s + | otherwise = s ++ "/" + +{- Reverses genSshUrl -} +parseSshUrl :: String -> Maybe SshData +parseSshUrl u + | "ssh://" `isPrefixOf` u = fromssh (drop (length "ssh://") u) + | otherwise = fromrsync u + where + mkdata (userhost, dir) = Just $ SshData + { sshHostName = T.pack host + , sshUserName = if null user then Nothing else Just $ T.pack user + , sshDirectory = T.pack dir + , sshRepoName = genSshRepoName host dir + -- dummy values, cannot determine from url + , sshPort = 22 + , needsPubKey = True + , sshCapabilities = [] + } + where + (user, host) = if '@' `elem` userhost + then separate (== '@') userhost + else ("", userhost) + fromrsync s + | not (rsyncUrlIsShell u) = Nothing + | otherwise = mkdata $ separate (== ':') s + fromssh = mkdata . break (== '/') + {- Generates a git remote name, like host_dir or host -} genSshRepoName :: String -> FilePath -> String genSshRepoName host dir diff --git a/Assistant/WebApp/Configurators/Ssh.hs b/Assistant/WebApp/Configurators/Ssh.hs index 91c6ab2127..7e8eb31962 100644 --- a/Assistant/WebApp/Configurators/Ssh.hs +++ b/Assistant/WebApp/Configurators/Ssh.hs @@ -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."