enabling ssh gcrypt now works

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

Assistant/Ssh.hs

@@ -1,6 +1,6 @@
 {- git-annex assistant ssh utilities
  -
- - Copyright 2012 Joey Hess <joey@kitenet.net>
+ - Copyright 2012-2013 Joey Hess <joey@kitenet.net>
  -
  - 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

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."