webapp: Generate better git remote names.

Wrote a better git remote name sanitizer. Git blows up on lots of weird
stuff, especially if it starts the remote name, but I managed to get
some common punctuation working.

4 files changed, 40 insertions, 10 deletions

diff --git a/Assistant/MakeRemote.hs b/Assistant/MakeRemote.hs
index 8f5d903e6..0cd3369be 100644
--- a/Assistant/MakeRemote.hs
+++ b/Assistant/MakeRemote.hs
@@ -19,10 +19,10 @@ import qualified Git.Command
 import qualified Command.InitRemote
 import Logs.UUID
 import Logs.Remote
+import Git.Remote
 
 import qualified Data.Text as T
 import qualified Data.Map as M
-import Data.Char
 
 {- Sets up and begins syncing with a new ssh or rsync remote. -}
 makeSshRemote :: Bool -> SshData -> Assistant Remote
@@ -112,6 +112,4 @@ uniqueRemoteName basename n r
 	name
 		| n == 0 = legalbasename
 		| otherwise = legalbasename ++ show n
-	legalbasename = filter legal basename
-	legal '_' = True
-	legal c = isAlphaNum c
+	legalbasename = makeLegalName basename
diff --git a/Assistant/Ssh.hs b/Assistant/Ssh.hs
index 69e633ac8..0b957cce9 100644
--- a/Assistant/Ssh.hs
+++ b/Assistant/Ssh.hs
@@ -10,6 +10,7 @@ module Assistant.Ssh where
 import Common.Annex
 import Utility.TempFile
 import Utility.UserInfo
+import Git.Remote
 
 import Data.Text (Text)
 import qualified Data.Text as T
@@ -51,14 +52,11 @@ sshDir = do
 genSshHost :: Text -> Maybe Text -> String
 genSshHost host user = maybe "" (\v -> T.unpack v ++ "@") user ++ T.unpack host
 
-{- host_dir, with all / in dir replaced by _, and bad characters removed -}
+{- Generates a git remote name, like host_dir or host -}
 genSshRepoName :: String -> FilePath -> String
 genSshRepoName host dir
-	| null dir = filter legal host
-	| otherwise = filter legal $ host ++ "_" ++ replace "/" "_" dir
-  where
-	legal '_' = True
-	legal c = isAlphaNum c
+	| null dir = makeLegalName host
+	| otherwise = makeLegalName $ host ++ "_" ++ dir
 
 {- The output of ssh, including both stdout and stderr. -}
 sshTranscript :: [String] -> String -> IO (String, Bool)
diff --git a/Git/Remote.hs b/Git/Remote.hs
new file mode 100644
index 000000000..5640e9ff2
--- /dev/null
+++ b/Git/Remote.hs
@@ -0,0 +1,33 @@
+{- git remote stuff
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Git.Remote where
+
+import Common
+import Data.Char
+
+{- Construct a legal git remote name out of an arbitrary input string.
+ -
+ - There seems to be no formal definition of this in the git source,
+ - just some ad-hoc checks, and some other things that fail with certian
+ - types of names (like ones starting with '-').
+ -}
+makeLegalName :: String -> String
+makeLegalName s = case filter legal $ replace "/" "_" s of
+	-- it can't be empty
+	[] -> "unnamed"
+	-- it can't start with / or - or .
+	'.':s' -> makeLegalName s'
+	'/':s' -> makeLegalName s'
+	'-':s' -> makeLegalName s'
+	s' -> s'
+  where
+	{- Only alphanumerics, and a few common bits of punctuation common
+	 - in hostnames. -}
+	legal '_' = True
+	legal '.' = True
+	legal c = isAlphaNum c
diff --git a/debian/changelog b/debian/changelog
index b7baf66e4..e65c34fef 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -37,6 +37,7 @@ git-annex (3.20121018) UNRELEASED; urgency=low
   * assistant: Fix syncing local drives.
   * webapp: Fix creation of rsync.net repositories.
   * webapp: Fix renaming of special remotes.
+  * webapp: Generate better git remote names.
 
  -- Joey Hess <joeyh@debian.org>  Wed, 17 Oct 2012 14:24:10 -0400