factor out more ssh stuff from git remote

This has the dual benefits of making Remote.Git shorter, and letting
Remote.GCrypt use these utilities.

2 files changed, 104 insertions, 12 deletions

diff --git a/Remote/Helper/Messages.hs b/Remote/Helper/Messages.hs
new file mode 100644
index 000000000..c4b1966dc
--- /dev/null
+++ b/Remote/Helper/Messages.hs
@@ -0,0 +1,17 @@
+{- git-annex remote messages
+ -
+ - Copyright 2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Remote.Helper.Messages where
+
+import Common.Annex
+import qualified Git
+
+showChecking :: Git.Repo -> Annex ()
+showChecking r = showAction $ "checking " ++ Git.repoDescribe r
+
+cantCheck :: Git.Repo -> Either String Bool
+cantCheck r = Left $ "unable to check " ++ Git.repoDescribe r
diff --git a/Remote/Helper/Ssh.hs b/Remote/Helper/Ssh.hs
index f8e9353b7..c71572434 100644
--- a/Remote/Helper/Ssh.hs
+++ b/Remote/Helper/Ssh.hs
@@ -1,6 +1,6 @@
-{- git-annex remote access with ssh
+{- git-annex remote access with ssh and git-annex-shell
  -
- - Copyright 2011,2012 Joey Hess <joey@kitenet.net>
+ - Copyright 2011-2013 Joey Hess <joey@kitenet.net>
  -
  - Licensed under the GNU GPL version 3 or higher.
  -}
@@ -12,19 +12,27 @@ import qualified Git
 import qualified Git.Url
 import Annex.UUID
 import Annex.Ssh
-import Fields
+import Fields (Field, fieldName)
+import qualified Fields
 import Types.GitConfig
+import Types.Key
+import Remote.Helper.Messages
+import Utility.Metered
+import Utility.Rsync
+import Config
+import Types.Remote
+import Logs.Transfer
 
 {- Generates parameters to ssh to a repository's host and run a command.
  - Caller is responsible for doing any neccessary shellEscaping of the
  - passed command. -}
-sshToRepo :: Git.Repo -> [CommandParam] -> Annex [CommandParam]
-sshToRepo repo sshcmd = do
+toRepo :: Git.Repo -> [CommandParam] -> Annex [CommandParam]
+toRepo r sshcmd = do
 	g <- fromRepo id
-	let c = extractRemoteGitConfig g (Git.repoDescribe repo)
+	let c = extractRemoteGitConfig g (Git.repoDescribe r)
 	let opts = map Param $ remoteAnnexSshOptions c
-	let host = Git.Url.hostuser repo
-	params <- sshCachingOptions (host, Git.Url.port repo) opts
+	let host = Git.Url.hostuser r
+	params <- sshCachingOptions (host, Git.Url.port r) opts
 	return $ params ++ Param host : sshcmd
 
 {- Generates parameters to run a git-annex-shell command on a remote
@@ -33,17 +41,17 @@ git_annex_shell :: Git.Repo -> String -> [CommandParam] -> [(Field, String)] ->
 git_annex_shell r command params fields
 	| not $ Git.repoIsUrl r = return $ Just (shellcmd, shellopts ++ fieldopts)
 	| Git.repoIsSsh r = do
-		uuid <- getRepoUUID r
-		sshparams <- sshToRepo r [Param $ sshcmd uuid ]
+		u <- getRepoUUID r
+		sshparams <- toRepo r [Param $ sshcmd u ]
 		return $ Just ("ssh", sshparams)
 	| otherwise = return Nothing
   where
 	dir = Git.repoPath r
 	shellcmd = "git-annex-shell"
 	shellopts = Param command : File dir : params
-	sshcmd uuid = unwords $
+	sshcmd u = unwords $
 		shellcmd : map shellEscape (toCommand shellopts) ++
-		uuidcheck uuid ++
+		uuidcheck u ++
 		map shellEscape (toCommand fieldopts)
 	uuidcheck NoUUID = []
 	uuidcheck (UUID u) = ["--uuid", u]
@@ -71,3 +79,70 @@ onRemote r (with, errorval) command params fields = do
 	case s of
 		Just (c, ps) -> liftIO $ with c ps
 		Nothing -> return errorval
+
+{- Checks if a remote contains a key. -}
+inAnnex :: Git.Repo -> Key -> Annex (Either String Bool)
+inAnnex r k = do
+	showChecking r
+	onRemote r (check, cantCheck r) "inannex" [Param $ key2file k] []
+  where
+	check c p = dispatch <$> safeSystem c p
+	dispatch ExitSuccess = Right True
+	dispatch (ExitFailure 1) = Right False
+	dispatch _ = cantCheck r
+
+{- Removes a key from a remote. -}
+dropKey :: Git.Repo -> Key -> Annex Bool
+dropKey r key = onRemote r (boolSystem, False) "dropkey"
+	[ Params "--quiet --force"
+	, Param $ key2file key
+	]
+	[]
+
+rsyncHelper :: Maybe MeterUpdate -> [CommandParam] -> Annex Bool
+rsyncHelper callback params = do
+	showOutput -- make way for progress bar
+	ifM (liftIO $ (maybe rsync rsyncProgress callback) params)
+		( return True
+		, do
+			showLongNote "rsync failed -- run git annex again to resume file transfer"
+			return False
+		)
+
+{- Generates rsync parameters that ssh to the remote and asks it
+ - to either receive or send the key's content. -}
+rsyncParamsRemote :: Remote -> Direction -> Key -> FilePath -> AssociatedFile -> Annex [CommandParam]
+rsyncParamsRemote r direction key file afile = do
+	u <- getUUID
+	direct <- isDirect
+	let fields = (Fields.remoteUUID, fromUUID u)
+		: (Fields.direct, if direct then "1" else "")
+		: maybe [] (\f -> [(Fields.associatedFile, f)]) afile
+	Just (shellcmd, shellparams) <- git_annex_shell (repo r)
+		(if direction == Download then "sendkey" else "recvkey")
+		[ Param $ key2file key ]
+		fields
+	-- Convert the ssh command into rsync command line.
+	let eparam = rsyncShell (Param shellcmd:shellparams)
+	let o = rsyncParams r
+	if direction == Download
+		then return $ o ++ rsyncopts eparam dummy (File file)
+		else return $ o ++ rsyncopts eparam (File file) dummy
+  where
+	rsyncopts ps source dest
+		| end ps == [dashdash] = ps ++ [source, dest]
+		| otherwise = ps ++ [dashdash, source, dest]
+	dashdash = Param "--"
+	{- The rsync shell parameter controls where rsync
+	 - goes, so the source/dest parameter can be a dummy value,
+	 - that just enables remote rsync mode.
+	 - For maximum compatability with some patched rsyncs,
+	 - the dummy value needs to still contain a hostname,
+	 - even though this hostname will never be used. -}
+	dummy = Param "dummy:"
+
+-- --inplace to resume partial files
+rsyncParams :: Remote -> [CommandParam]
+rsyncParams r = [Params "--progress --inplace"] ++
+	map Param (remoteAnnexRsyncOptions $ gitconfig r)
+