git-annex-shell now exclusively used for all remote access

Backend/File.hs

@@ -65,12 +65,7 @@ copyKeyFile key file = do
 		trycopy full (r:rs) = do
 			probablythere <- probablyPresent r
 			if probablythere
-				then do
+				then docopy r (trycopy full rs)
-					showNote $ "copying from " ++ Git.repoDescribe r ++ "..."
-					copied <- Remotes.copyFromRemote r key file
-					if copied
-						then return True
-						else trycopy full rs
 				else trycopy full rs
 		-- This check is to avoid an ugly message if a remote is a
 		-- drive that is not mounted. Avoid checking inAnnex for ssh
@@ -82,6 +77,12 @@ copyKeyFile key file = do
 			if not $ Git.repoIsUrl r
 				then liftIO $ doesFileExist $ annexLocation r key
 				else return True
+		docopy r continue = do
+			showNote $ "copying from " ++ Git.repoDescribe r ++ "..."
+			copied <- Remotes.copyFromRemote r key file
+			if copied
+				then return True
+				else continue
 
 {- Checks remotes to verify that enough copies of a key exist to allow
  - for a key to be safely removed (with no data loss), and fails with an

Command/Move.hs

@@ -7,13 +7,11 @@
 
 module Command.Move where
 
-import Control.Monad (when)
 import Control.Monad.State (liftIO)
 
 import Command
 import qualified Command.Drop
 import qualified Annex
-import Locations
 import LocationLog
 import Types
 import Core
@@ -86,26 +84,17 @@ toPerform move key = do
 			return Nothing
 		Right False -> do
 			showNote $ "to " ++ Git.repoDescribe remote ++ "..."
-			let tmpfile = annexTmpLocation remote ++ keyFile key
+			ok <- Remotes.copyToRemote remote key
-			ok <- Remotes.copyToRemote remote key tmpfile
 			if ok
-				then return $ Just $ toCleanup move remote key tmpfile
+				then return $ Just $ toCleanup move remote key
 				else return Nothing -- failed
 		Right True -> return $ Just $ Command.Drop.cleanup key
-toCleanup :: Bool -> Git.Repo -> Key -> FilePath -> CommandCleanup
+toCleanup :: Bool -> Git.Repo -> Key -> CommandCleanup
-toCleanup move remote key tmpfile = do
+toCleanup move remote key = do
-	-- Tell remote to use the transferred content.
+	remoteHasKey remote key True
-	ok <- Remotes.runCmd remote "git-annex" ["setkey", "--quiet",
+	if move
-		"--backend=" ++ backendName key,
+		then Command.Drop.cleanup key
-		"--key=" ++ keyName key,
+		else return True
-		tmpfile]
-	if ok
-		then do
-			remoteHasKey remote key True
-			if move
-				then Command.Drop.cleanup key
-				else return True
-		else return False
 
 {- Moves (or copies) the content of an annexed file from another repository
  - to the current repository and updates locationlog information on both.
@@ -140,7 +129,9 @@ fromCleanup True remote key = do
 		["--quiet", "--force",
 		"--backend=" ++ backendName key,
 		keyName key]
-	when ok $
+	-- better safe than sorry: assume the remote dropped the key
-		remoteHasKey remote key False
+	-- even if it seemed to fail; the failure could have occurred
+	-- after it really dropped it
+	remoteHasKey remote key False
 	return ok
 fromCleanup False _ _ = return True

Command/RecvKey.hs

@@ -34,5 +34,9 @@ start keyname = do
 	
 	ok <- getViaTmp key (liftIO . rsyncServerReceive)
 	if ok
-		then return Nothing
+		then do
+			-- forcibly quit after receiving one key,
+			-- and shutdown cleanly so queued git commands run
+			_ <- shutdown 0
+			liftIO exitSuccess
 		else liftIO exitFailure

Remotes.hs

@@ -15,7 +15,6 @@ module Remotes (
 	byName,
 	copyFromRemote,
 	copyToRemote,
-	runCmd,
 	onRemote
 ) where
 
@@ -23,11 +22,10 @@ import Control.Exception.Extensible
 import Control.Monad.State (liftIO)
 import qualified Data.Map as Map
 import Data.String.Utils
-import System.Directory hiding (copyFile)
-import System.Posix.Directory
 import System.Cmd.Utils
 import Data.List (intersect, sortBy)
 import Control.Monad (when, unless, filterM)
+import Data.Maybe
 
 import Types
 import qualified GitRepo as Git
@@ -39,6 +37,7 @@ import Utility
 import qualified Core
 import Messages
 import CopyFile
+import RsyncFile
 
 {- Human visible list of remotes. -}
 list :: [Git.Repo] -> String
@@ -227,92 +226,95 @@ tryGitConfigRead r
 				then new : exchange ls new
 				else old : exchange ls new
 
-{- Tries to copy a key's content from a remote to a file. -}
+{- Tries to copy a key's content from a remote's annex to a file. -}
 copyFromRemote :: Git.Repo -> Key -> FilePath -> Annex Bool
 copyFromRemote r key file
-	| not $ Git.repoIsUrl r = getlocal
+	| not $ Git.repoIsUrl r = liftIO $ copyFile (annexLocation r key) file
-	| Git.repoIsSsh r = getssh
+	| Git.repoIsSsh r = rsynchelper r True key file
 	| otherwise = error "copying from non-ssh repo not supported"
-	where
-		keyloc = annexLocation r key
-		getlocal = liftIO $ copyFile keyloc file
-		getssh = remoteCopyFile True r (sshLocation r keyloc) file
 
-{- Tries to copy a key's content to a file on a remote. -}
+{- Tries to copy a key's content to a remote's annex. -}
-copyToRemote :: Git.Repo -> Key -> FilePath -> Annex Bool
+copyToRemote :: Git.Repo -> Key -> Annex Bool
-copyToRemote r key file = do
+copyToRemote r key
-	g <- Annex.gitRepo
+	| not $ Git.repoIsUrl r = do
-	let keyloc = annexLocation g key
+		g <- Annex.gitRepo
-	if not $ Git.repoIsUrl r
+		let keysrc = annexLocation g key
-		then putlocal keyloc
+		let keydest = annexLocation r key
-		else if Git.repoIsSsh r
+		liftIO $ copyFile keysrc keydest
-			then putssh keyloc
+	| Git.repoIsSsh r = do
-			else error "copying to non-ssh repo not supported"
+		g <- Annex.gitRepo
-	where
+		let keysrc = annexLocation g key
-		putlocal src = liftIO $ copyFile src file
+		rsynchelper r False key keysrc
-		putssh src = remoteCopyFile False r src (sshLocation r file)
+	| otherwise = error "copying to non-ssh repo not supported"
 
-sshLocation :: Git.Repo -> FilePath -> FilePath
+rsynchelper :: Git.Repo -> Bool -> Key -> FilePath -> Annex (Bool)
-sshLocation r file = Git.urlHost r ++ ":" ++ shellEscape file
+rsynchelper r sending key file = do
-
-{- Copies a file from or to a remote, using rsync. -}
-remoteCopyFile :: Bool -> Git.Repo -> String -> String -> Annex Bool
-remoteCopyFile recv r src dest = do
 	showProgress -- make way for progress bar
-	o <- repoConfig r configopt ""
+	p <- rsyncParams r sending key file
-	res <- liftIO $ boolSystem cmd $ options ++ words o ++ [src, dest]
+	liftIO $ putStrLn $ unwords p
+	res <- liftIO $ boolSystem "rsync" p
 	if res
 		then return res
 		else do
 			showLongNote "rsync failed -- run git annex again to resume file transfer"
 			return res
+
+{- Generates rsync parameters that ssh to the remote and asks it
+ - to either receive or send the key's content. -}
+rsyncParams :: Git.Repo -> Bool -> Key -> FilePath -> Annex [String]
+rsyncParams r sending key file = do
+	-- Note that the command is terminated with "--", because
+	-- rsync will tack on its own options to this command,
+	-- and they need to be ignored.
+	shellcmd <- git_annex_shell r
+		(if sending then "sendkey" else "recvkey")
+		["--backend=" ++ backendName key, keyName key, "--"]
+	-- Convert the ssh command into rsync command line.
+	let eparam = rsyncShell $ fromJust shellcmd
+	o <- repoConfig r "rsync-options" ""
+	let base = options ++ words o ++ eparam
+	if sending
+		then return $ base ++ [dummy, file]
+		else return $ base ++ [file, dummy]
 	where
-		cmd = "rsync"
-		configopt= "rsync-options"
 		-- inplace makes rsync resume partial files
 		options = ["-p", "--progress", "--inplace"]
+		-- the rsync shell parameter controls where rsync
+		-- does, so the source/dest parameter can be a dummy value,
+		-- that just enables remote rsync mode.
+		dummy = ":"
 
-{- Uses a supplied function to run a git-annex-shell command on a remote. -}
+{- Uses a supplied function to run a git-annex-shell command on a remote.
+ -
+ - Or, if the remote does not support running remote commands, returns
+ - a specified error value. -}
 onRemote 
 	:: Git.Repo
-	-> ((String -> [String] -> IO a), a)
+	-> (String -> [String] -> IO a, a)
 	-> String
 	-> [String]
 	-> Annex a
-onRemote r (with, errorval) command params
+onRemote r (with, errorval) command params = do
-	| not $ Git.repoIsUrl r = liftIO $ with shellcmd shellopts
+	s <- git_annex_shell r command params
+	case s of
+		Just shellcmd -> liftIO $ with (shellcmd !! 0) (tail shellcmd)
+		Nothing -> return errorval
+
+{- Generates parameters to run a git-annex-shell command on a remote. -}
+git_annex_shell :: Git.Repo -> String -> [String] -> Annex (Maybe [String])
+git_annex_shell r command params
+	| not $ Git.repoIsUrl r = return $ Just (shellcmd:shellopts)
 	| Git.repoIsSsh r = do
 		sshoptions <- repoConfig r "ssh-options" ""
-		liftIO $ with "ssh" $
+		return $ Just $ ["ssh"] ++ words sshoptions ++ 
-			words sshoptions ++ [Git.urlHost r, sshcmd]
+			[Git.urlHost r, sshcmd]
-	| otherwise = return errorval
+	| otherwise = return Nothing
 	where
 		dir = Git.workTree r
 		shellcmd = "git-annex-shell"
 		shellopts = command:dir:params
 		sshcmd = shellcmd ++ " " ++ unwords (map shellEscape shellopts)
 
-{- Runs a command in a remote, using ssh if necessary.
- - (Honors annex-ssh-options.) -}
-runCmd :: Git.Repo -> String -> [String] -> Annex Bool
-runCmd r command params = do
-	sshoptions <- repoConfig r "ssh-options" ""
-	if not $ Git.repoIsUrl r
-		then do
-			cwd <- liftIO getCurrentDirectory
-			liftIO $ bracket_
-				(changeWorkingDirectory (Git.workTree r))
-				(changeWorkingDirectory cwd)
-				(boolSystem command params)
-		else if Git.repoIsSsh r
-			then liftIO $ boolSystem "ssh" $
-				words sshoptions ++ [Git.urlHost r, sshcmd]
-			else error "running command in non-ssh repo not supported"
-	where 
-		sshcmd = "cd " ++ shellEscape (Git.workTree r) ++
-			" && " ++ shellEscape command ++ " " ++
-			unwords (map shellEscape params)
-
 {- Looks up a per-remote config option in git config.
  - Failing that, tries looking for a global config option. -}
 repoConfig :: Git.Repo -> String -> String -> Annex String

RsyncFile.hs

@@ -7,8 +7,20 @@
 
 module RsyncFile where
 
-import Utility
 import System.Posix.Process
+import Data.String.Utils
+
+import Utility
+
+{- Generates parameters to make rsync use a specified command as its remote
+ - shell. -}
+rsyncShell :: [String] -> [String]
+rsyncShell command = ["-e", unwords $ map escape command]
+	where
+		{- rsync requires some weird, non-shell like quoting in
+                 - here. A doubled single quote inside the single quoted
+                 - string is a single quote. -}
+		escape s = "'" ++  (join "''" $ split "'" s) ++ "'"
 
 {- Runs rsync in server mode to send a file, and exits. -}
 rsyncServerSend :: FilePath -> IO ()

doc/todo/git-annex-shell.mdwn

@@ -1,3 +1,5 @@
+[[done]]
+
 I've been considering adding a `git-annex-shell` command. This would
 be similar to `git-shell` (and in fact would pass unknown commands off to
 `git-shell`).
@@ -11,38 +13,3 @@ be similar to `git-shell` (and in fact would pass unknown commands off to
 * Could possibly allow multiple things to be done with one ssh connection
   in future.
 * Allows expanding `~` and `~user` in repopath on the remote system.
-
-## Design
-
-`git-annex-shell -c <command> <repopath> <arguments>`
-
-### options
-
-Need at least `--quiet`, `--backend`, `--key`, `--force`
-
-### commands
-
-* `configlist repopath`
-
-  Returns `git config --list`, for use by `tryGitConfigRead`.
-  
-  May filter the listed config to only the options git-annex really needs,
-  to prevent info disclosure.
-
-* `inannex repopath key ...`
-
-  Checks if the keys are in the annex; shell exits zero if so.
-
-* `dropkey repopath key ... `
-
-  Same as `git annex dropkey`, and taking the same dashed options.
-
-* `setkey repopath tmpfile`
-
-  Same as `git annex setkey`, and taking the same dashed options.
-
-### TODO
-
-* To be usable as a locked down shell, needs a way to launch the
-  rsync server, for file receiving. Safely?
-* Also needs a way to support receiving files by scp.