From 14fe13dc2b0f39857eeccdc36483d0f4a0d81fdc Mon Sep 17 00:00:00 2001
From: Joey Hess <joey@kitenet.net>
Date: Fri, 31 Dec 2010 21:22:03 -0400
Subject: [PATCH] support ssh urls containing "~", and relative user:path

---
 GitRepo.hs                                    | 36 ++++++++++++++++++-
 debian/changelog                              |  5 ++-
 .../wishlist:_support_for_more_ssh_urls_.mdwn |  4 ++-
 git-annex-shell.hs                            |  3 +-
 4 files changed, 42 insertions(+), 6 deletions(-)

diff --git a/GitRepo.hs b/GitRepo.hs
index 9dfce0d35b..07f243b661 100644
--- a/GitRepo.hs
+++ b/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
diff --git a/debian/changelog b/debian/changelog
index d74eb8e369..b5d0058cc8 100644
--- a/debian/changelog
+++ b/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
diff --git a/doc/bugs/wishlist:_support_for_more_ssh_urls_.mdwn b/doc/bugs/wishlist:_support_for_more_ssh_urls_.mdwn
index ee3b4a64ad..55b8120a75 100644
--- a/doc/bugs/wishlist:_support_for_more_ssh_urls_.mdwn
+++ b/doc/bugs/wishlist:_support_for_more_ssh_urls_.mdwn
@@ -17,4 +17,6 @@ Specifically, if I have ~/bar set up on host foo:
 > code on the remote to lookup homedirs. If git-annex grows a
 > `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]] 
+> could handle the expansions there. --[[Joey]]
+
+> Update: Now `~` expansions are supported. [[done]]
diff --git a/git-annex-shell.hs b/git-annex-shell.hs
index 251acf6132..78dd777904 100644
--- a/git-annex-shell.hs
+++ b/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 ()