support checking network remotes when dropping

3 files changed, 39 insertions, 18 deletions

diff --git a/Backend/File.hs b/Backend/File.hs
index b99a064ae..15d8f4a26 100644
--- a/Backend/File.hs
+++ b/Backend/File.hs
@@ -44,9 +44,18 @@ mustProvide = error "must provide this field"
 dummyStore :: FilePath -> Key -> Annex (Bool)
 dummyStore file key = return True
 
-{- Just check if the .git/annex/ file for the key exists. -}
+{- Just check if the .git/annex/ file for the key exists. 
+ -
+ - But, if running against a remote annex, need to use ssh to do it. -}
 checkKeyFile :: Key -> Annex Bool
-checkKeyFile k = inAnnex k
+checkKeyFile k = do
+	g <- Annex.gitRepo
+	if (not $ Git.repoIsUrl g)
+		then inAnnex k
+		else do
+			showNote ("checking " ++ Git.repoDescribe g ++ "...")
+			liftIO $ boolSystem "ssh" [Git.urlHost g,
+				"test -e " ++ (shellEscape $ annexLocation g k)]
 
 {- Try to find a copy of the file in one of the remotes,
  - and copy it over to this one. -}
@@ -85,11 +94,13 @@ copyFromRemote r key file = do
 			then getssh
 			else error "copying from non-ssh repo not supported"
 	where
-		location = annexLocation r key
 		getlocal = boolSystem "cp" ["-a", location, file]
 		getssh = do
 			liftIO $ putStrLn "" -- make way for scp progress bar
-			boolSystem "scp" [location, file]
+			-- TODO double-shell-quote path for scp
+			boolSystem "scp" [sshlocation, file]
+		location = annexLocation r key
+		sshlocation = (Git.urlHost r) ++ ":" ++ location
 
 showLocations :: Key -> Annex ()
 showLocations key = do
diff --git a/GitRepo.hs b/GitRepo.hs
index ea9e8a8b7..553e91fec 100644
--- a/GitRepo.hs
+++ b/GitRepo.hs
@@ -16,6 +16,8 @@ module GitRepo (
 	workTree,
 	dir,
 	relative,
+	urlPath,
+	urlHost,
 	configGet,
 	configMap,
 	configRead,
@@ -110,7 +112,7 @@ repoIsSsh repo = repoIsUrl repo && (uriScheme $ url repo) == "ssh:"
 assertLocal repo action = 
 	if (not $ repoIsUrl repo)
 		then action
-		else error $ "acting on remote git repo " ++  (repoDescribe repo) ++ 
+		else error $ "acting on URL git repo " ++  (repoDescribe repo) ++ 
 				" not supported"
 assertUrl repo action = 
 	if (repoIsUrl repo)
@@ -137,23 +139,18 @@ attributes repo = assertLocal repo $ do
 		then (top repo) ++ "/info/.gitattributes"
 		else (top repo) ++ "/.gitattributes"
 
-{- Path to a repository's .git directory, relative to its topdir. -}
+{- Path to a repository's .git directory, relative to its workTree. -}
 dir :: Repo -> String
 dir repo = if (bare repo) then "" else ".git"
 
-{- Path to a repository's --work-tree. -}
+{- Path to a repository's --work-tree, that is, its top.
+ -
+ - Note that for URL repositories, this is relative to the urlHost -}
 workTree :: Repo -> FilePath
 workTree repo =
 	if (not $ repoIsUrl repo)
 		then top repo
-		else assertssh repo $ (remoteHost repo) ++ ":" ++ (uriPath $ url repo)
-
-{- Hostname for a remote repo. (May include a username and/or port too.) -}
-remoteHost :: Repo -> String
-remoteHost repo = assertUrl repo $ 
-	(uriUserInfo a) ++ (uriRegName a) ++ (uriPort a)
-	where 
-		a = fromJust $ uriAuthority $ url repo
+		else urlPath repo
 
 {- Given a relative or absolute filename in a repository, calculates the
  - name to use to refer to the file relative to a git repository's top.
@@ -170,6 +167,18 @@ relative repo file = drop (length absrepo) absfile
 			Just f -> f
 			Nothing -> error $ file ++ " is not located inside git repository " ++ absrepo
 
+{- Hostname of an URL repo. (May include a username and/or port too.) -}
+urlHost :: Repo -> String
+urlHost repo = assertUrl repo $ 
+	(uriUserInfo a) ++ (uriRegName a) ++ (uriPort a)
+	where 
+		a = fromJust $ uriAuthority $ url repo
+
+{- Path of an URL repo. -}
+urlPath :: Repo -> String
+urlPath repo = assertUrl repo $
+	uriPath $ url repo
+
 {- Constructs a git command line operating on the specified repo. -}
 gitCommandLine :: Repo -> [String] -> [String]
 gitCommandLine repo params = assertLocal repo $
@@ -215,9 +224,9 @@ configRead repo =
 			(\_ -> changeWorkingDirectory cwd) $
 				pOpen ReadFromPipe "git" ["config", "--list"] proc
 	else assertssh repo $ do
-		pOpen ReadFromPipe "ssh" [remoteHost repo, sshcommand] proc
+		pOpen ReadFromPipe "ssh" [urlHost repo, sshcommand] proc
 	where
-		sshcommand = "cd '" ++ (uriPath $ url repo) ++ "' && git config --list"
+		sshcommand = "cd " ++ (shellEscape $ urlPath repo) ++ " && git config --list"
 		proc h = do
 			val <- hGetContentsStrict h
 			let r = repo { config = configParse val }
diff --git a/debian/changelog b/debian/changelog
index 2800e54a3..3d791ffe5 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -1,7 +1,8 @@
 git-annex (0.02) UNRELEASED; urgency=low
 
   * New fromkey subcommand, for registering urls, etc.
-  * Can scp annexed files from remotes.
+  * Can scp annexed files from remote hosts, and check remote hosts for
+    file content when dropping files.
 
  -- Joey Hess <joeyh@debian.org>  Thu, 21 Oct 2010 16:38:00 -0400