Allow rsync to use other remote shells.

Introduced a new per-remote option 'annex-rsync-transport' to specify
the remote shell that it to be used with rsync. In case the value is
'ssh', connections are cached unless 'sshcaching' is unset.

5 files changed, 58 insertions, 11 deletions

diff --git a/Annex/Ssh.hs b/Annex/Ssh.hs
index 0b8ce3b93..cf92bd248 100644
--- a/Annex/Ssh.hs
+++ b/Annex/Ssh.hs
@@ -8,8 +8,9 @@
 {-# LANGUAGE CPP #-}
 
 module Annex.Ssh (
-	sshParams,
+	sshCachingOptions,
 	sshCleanup,
+	sshReadPort,
 ) where
 
 import qualified Data.Map as M
@@ -24,8 +25,8 @@ import Config
 
 {- Generates parameters to ssh to a given host (or user@host) on a given
  - port, with connection caching. -}
-sshParams :: (String, Maybe Integer) -> [CommandParam] -> Annex [CommandParam]
-sshParams (host, port) opts = go =<< sshInfo (host, port)
+sshCachingOptions :: (String, Maybe Integer) -> [CommandParam] -> Annex [CommandParam]
+sshCachingOptions (host, port) opts = go =<< sshInfo (host, port)
   where
 	go (Nothing, params) = ret params
 	go (Just socketfile, params) = do
@@ -33,8 +34,7 @@ sshParams (host, port) opts = go =<< sshInfo (host, port)
 		liftIO $ createDirectoryIfMissing True $ parentDir socketfile
 		lockFile $ socket2lock socketfile
 		ret params
-	ret ps = return $ ps ++ opts ++ portParams port ++
-		[Param "-T", Param host]
+	ret ps = return $ ps ++ opts ++ portParams port ++ [Param "-T"]
 	-- If the lock pool is empty, this is the first ssh of this
 	-- run. There could be stale ssh connections hanging around
 	-- from a previous git-annex run that was interrupted.
@@ -154,3 +154,15 @@ sizeof_sockaddr_un_sun_path = 100
  - appear on disk. -}
 valid_unix_socket_path :: FilePath -> Bool
 valid_unix_socket_path f = length (decodeW8 f) < sizeof_sockaddr_un_sun_path
+
+{- Parses the SSH port, and returns the other OpenSSH options. If
+ - several ports are found, the last one takes precedence. -}
+sshReadPort :: [String] -> (Maybe Integer, [String])
+sshReadPort params = (port, reverse args)
+  where
+	(port,args) = aux (Nothing, []) params
+	aux (p,ps) [] = (p,ps)
+	aux (_,ps) ("-p":p:rest) = aux (readPort p, ps) rest
+	aux (p,ps) (q:rest) | "-p" `isPrefixOf` q = aux (readPort $ drop 2 q, ps) rest
+			    | otherwise = aux (p,q:ps) rest
+	readPort p = fmap fst $ listToMaybe $ reads p
diff --git a/Remote/Helper/Ssh.hs b/Remote/Helper/Ssh.hs
index 135b5c144..2e6b6d57c 100644
--- a/Remote/Helper/Ssh.hs
+++ b/Remote/Helper/Ssh.hs
@@ -22,9 +22,10 @@ sshToRepo :: Git.Repo -> [CommandParam] -> Annex [CommandParam]
 sshToRepo repo sshcmd = do
 	g <- fromRepo id
 	let c = extractRemoteGitConfig g (Git.repoDescribe repo)
-	let opts = map Param $ remoteAnnexSshOptions c
-	params <- sshParams (Git.Url.hostuser repo, Git.Url.port repo) opts
-	return $ params ++ sshcmd
+	    opts = map Param $ remoteAnnexSshOptions c
+            host = Git.Url.hostuser repo
+	params <- sshCachingOptions (host, Git.Url.port repo) opts
+	return $ params ++ Param host : sshcmd
 
 {- Generates parameters to run a git-annex-shell command on a remote
  - repository. -}
diff --git a/Remote/Rsync.hs b/Remote/Rsync.hs
index deaf4de46..88540a34b 100644
--- a/Remote/Rsync.hs
+++ b/Remote/Rsync.hs
@@ -17,6 +17,7 @@ import qualified Git
 import Config
 import Config.Cost
 import Annex.Content
+import Annex.Ssh
 import Remote.Helper.Special
 import Remote.Helper.Encryptable
 import Crypto
@@ -44,6 +45,9 @@ remote = RemoteType {
 gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex Remote
 gen r u c gc = do
 	cst <- remoteCost gc expensiveRemoteCost
+	(transport, url) <- rsyncTransport
+	let o = RsyncOpts url (transport ++ opts) escape
+	    islocal = rsyncUrlIsPath $ rsyncUrl o
 	return $ encryptableRemote c
 		(storeEncrypted o $ getGpgOpts gc)
 		(retrieveEncrypted o)
@@ -69,9 +73,6 @@ gen r u c gc = do
 			, remotetype = remote
 			}
   where
-	o = RsyncOpts url opts escape
-	islocal = rsyncUrlIsPath $ rsyncUrl o
-	url = fromMaybe (error "missing rsyncurl") $ remoteAnnexRsyncUrl gc
 	opts = map Param $ filter safe $ remoteAnnexRsyncOptions gc
 	escape = M.lookup "shellescape" c /= Just "no"
 	safe opt
@@ -81,6 +82,28 @@ gen r u c gc = do
 		| opt == "--delete" = False
 		| opt == "--delete-excluded" = False
 		| otherwise = True
+	rawurl = fromMaybe (error "missing rsyncurl") $ remoteAnnexRsyncUrl gc
+	(login,resturl) = case separate (=='@') rawurl of
+			(h, "") -> (Nothing, h)
+			(l, h)  -> (Just l, h)
+	loginopt = maybe [] (\l -> ["-l",l]) login
+	fromNull as xs | null xs = as
+		       | otherwise = xs
+	rsyncTransport = if rsyncUrlIsShell rawurl
+		then (\rsh -> return (rsyncShell rsh, resturl)) =<<
+			case fromNull ["ssh"] (remoteAnnexRsyncTransport gc) of
+				"ssh":sshopts -> do
+					let (port, sshopts') = sshReadPort sshopts
+					    host = takeWhile (/=':') resturl
+					-- Connection caching
+					(Param "ssh":) <$> sshCachingOptions
+						(host, port)
+						(map Param $ loginopt ++ sshopts')
+				"rsh":rshopts -> return $ map Param $ "rsh" :
+					loginopt ++ rshopts
+				rsh -> error $ "Unknown Rsync transport: "
+					++ unwords rsh
+		else return ([], rawurl)
 
 rsyncSetup :: UUID -> RemoteConfig -> Annex RemoteConfig
 rsyncSetup u c = do
diff --git a/Types/GitConfig.hs b/Types/GitConfig.hs
index ee818574b..888795cbb 100644
--- a/Types/GitConfig.hs
+++ b/Types/GitConfig.hs
@@ -94,6 +94,7 @@ data RemoteGitConfig = RemoteGitConfig
 	 - including special remotes. -}
 	, remoteAnnexSshOptions :: [String]
 	, remoteAnnexRsyncOptions :: [String]
+	, remoteAnnexRsyncTransport :: [String]
 	, remoteAnnexGnupgOptions :: [String]
 	, remoteAnnexRsyncUrl :: Maybe String
 	, remoteAnnexBupRepo :: Maybe String
@@ -116,6 +117,7 @@ extractRemoteGitConfig r remotename = RemoteGitConfig
 
 	, remoteAnnexSshOptions = getoptions "ssh-options"
 	, remoteAnnexRsyncOptions = getoptions "rsync-options"
+	, remoteAnnexRsyncTransport = getoptions "rsync-transport"
 	, remoteAnnexGnupgOptions = getoptions "gnupg-options"
 	, remoteAnnexRsyncUrl = notempty $ getmaybe "rsyncurl"
 	, remoteAnnexBupRepo = getmaybe "buprepo"
diff --git a/doc/git-annex.mdwn b/doc/git-annex.mdwn
index 60ce3a9ae..b9badce9b 100644
--- a/doc/git-annex.mdwn
+++ b/doc/git-annex.mdwn
@@ -943,6 +943,15 @@ Here are all the supported configuration settings.
   to or from this remote. For example, to force ipv6, and limit
   the bandwidth to 100Kbyte/s, set it to "-6 --bwlimit 100"
 
+* `remote.<name>.annex-rsync-transport`
+
+  The remote shell to use to connect to the rsync remote. Possible
+  values are `ssh` (the default) and `rsh`, together with their
+  arguments, for instance `ssh -p 2222 -c blowfish`; Note that the
+  remote hostname should not appear there, see rsync(1) for details.
+  When the transport used is `ssh`, connections are automatically cached
+  unless `annex.sshcaching` is unset.
+
 * `remote.<name>.annex-bup-split-options`
 
   Options to pass to bup split when storing content in this remote.