webapp: Ensure that ssh keys generated for different directories on a server are always different.

1 files changed, 9 insertions, 1 deletions

diff --git a/Assistant/Ssh.hs b/Assistant/Ssh.hs
index 87347571e..38ec347cb 100644
--- a/Assistant/Ssh.hs
+++ b/Assistant/Ssh.hs
@@ -16,6 +16,7 @@ import Git.Remote
 import Data.Text (Text)
 import qualified Data.Text as T
 import Data.Char
+import Network.URI
 
 data SshData = SshData
 	{ sshHostName :: Text
@@ -216,10 +217,16 @@ setSshConfig sshdata config = do
 
 {- This hostname is specific to a given repository on the ssh host,
  - so it is based on the real hostname, the username, and the directory.
+ -
+ - The mangled hostname has the form "git-annex-realhostname-username_dir".
+ - The only use of "-" is to separate the parts shown; this is necessary
+ - to allow unMangleSshHostName to work. Any unusual characters in the
+ - username or directory are url encoded, except using "." rather than "%"
+ - (the latter has special meaning to ssh).
  -}
 mangleSshHostName :: SshData -> String
 mangleSshHostName sshdata = "git-annex-" ++ T.unpack (sshHostName sshdata)
-	++ "-" ++ filter safe extra
+	++ "-" ++ escape extra
   where
 	extra = intercalate "_" $ map T.unpack $ catMaybes
 		[ sshUserName sshdata
@@ -229,6 +236,7 @@ mangleSshHostName sshdata = "git-annex-" ++ T.unpack (sshHostName sshdata)
 		| isAlphaNum c = True
 		| c == '_' = True
 		| otherwise = False
+	escape s = replace "%" "." $ escapeURIString safe s
 
 {- Extracts the real hostname from a mangled ssh hostname. -}
 unMangleSshHostName :: String -> String