support ssh urls containing "~", and relative user:path

GitRepo.hs

@@ -43,6 +43,7 @@ module GitRepo (
 	encodeGitFile,
 	typeChangedFiles,
 	typeChangedStagedFiles,
+	absDir,
 
 	prop_idempotent_deencode
 ) where
@@ -50,6 +51,7 @@ module GitRepo (
 import Control.Monad (unless)
 import System.Directory
 import System.Posix.Directory
+import System.Posix.User
 import System.Path
 import System.Cmd.Utils
 import IO (bracket_)
@@ -62,7 +64,7 @@ import Data.Char
 import Data.Word (Word8)
 import Codec.Binary.UTF8.String (encode)
 import Text.Printf
-import Data.List (isInfixOf)
+import Data.List (isInfixOf, isPrefixOf)
 
 import Utility
 
@@ -444,6 +446,38 @@ encodeGitFile s = foldl (++) "\"" (map echar s) ++ "\""
 prop_idempotent_deencode :: String -> Bool
 prop_idempotent_deencode s = s == decodeGitFile (encodeGitFile s)
 
+{- Git ssh remotes can have a directory that is specified relative
+ - to a home directory. This converts such a directory to an absolute path.
+ - Note that it has to run on the remote system.
+ -}
+absDir :: String -> IO String
+absDir d
+	| isPrefixOf "/" d = expandt d
+	| otherwise = do
+		h <- myhomedir
+		return $ h ++ d
+	where
+		homedir u = (homeDirectory u) ++ "/"
+		myhomedir = do
+			uid <- getEffectiveUserID
+			u <- getUserEntryForID uid
+			return $ homedir u
+		expandt [] = return ""
+		expandt ('/':'~':'/':cs) = do
+			h <- myhomedir
+			return $ h ++ cs
+		expandt ('/':'~':cs) = do
+			let (name, rest) = findname "" cs
+			u <- getUserEntryForName name
+			return $ homedir u ++ rest
+		expandt (c:cs) = do
+			v <- expandt cs
+			return (c:v)
+		findname n [] = (n, "")
+		findname n (c:cs)
+			| c == '/' = (n, cs)
+			| otherwise = findname (n++[c]) cs
+
 {- Finds the current git repository, which may be in a parent directory. -}
 repoFromCwd :: IO Repo
 repoFromCwd = do

debian/changelog

@@ -1,8 +1,7 @@
 git-annex (0.15) UNRELEASED; urgency=low
 
-  * Support scp-style urls for remotes (host:path). Note that
-    paths relative to the user's home directory, or containing "~" are
-    not yet supported.
+  * Support scp-style urls for remotes (host:path).
+  * Support ssh urls containing "~".
   * Add trust and untrust subcommands, to allow configuring repositories
     that are trusted to retain files without explicit checking.
   * Fix bug in numcopies handling when multiple remotes pointed to the

doc/bugs/wishlist:_support_for_more_ssh_urls_.mdwn

@@ -18,3 +18,5 @@ Specifically, if I have ~/bar set up on host foo:
 > `git annex shell` that is run on the remote side
 > (something I am [[considering|todo/git-annex-shell]] for other reasons), it
 > could handle the expansions there. --[[Joey]]
+
+> Update: Now `~` expansions are supported. [[done]]

git-annex-shell.hs

@@ -60,7 +60,8 @@ builtins = map cmdname cmds
 
 builtin :: String -> String -> [String] -> IO ()
 builtin cmd dir params = do
-	let gitrepo = Git.repoFromPath dir
+	dir' <- Git.absDir dir
+	let gitrepo = Git.repoFromPath dir'
 	dispatch gitrepo (cmd:(filterparams params)) cmds commonOptions header
 
 external :: [String] -> IO ()