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.

4 files changed, 127 insertions, 93 deletions

diff --git a/Remote/Bup.hs b/Remote/Bup.hs
index 16fe8c8c5..1acb35c82 100644
--- a/Remote/Bup.hs
+++ b/Remote/Bup.hs
@@ -22,9 +22,10 @@ import qualified Git.Construct
 import qualified Git.Ref
 import Config
 import Config.Cost
-import Remote.Helper.Ssh
+import qualified Remote.Helper.Ssh as Ssh
 import Remote.Helper.Special
 import Remote.Helper.Encryptable
+import Remote.Helper.Messages
 import Crypto
 import Utility.Hash
 import Utility.UserInfo
@@ -185,7 +186,7 @@ rollback k bupr = go =<< liftIO (bup2GitRemote bupr)
 checkPresent :: Git.Repo -> Git.Repo -> Key -> Annex (Either String Bool)
 checkPresent r bupr k
 	| Git.repoIsUrl bupr = do
-		showAction $ "checking " ++ Git.repoDescribe r
+		showChecking r
 		ok <- onBupRemote bupr boolSystem "git" params
 		return $ Right ok
 	| otherwise = liftIO $ catchMsgIO $
@@ -220,7 +221,7 @@ storeBupUUID u buprepo = do
 
 onBupRemote :: Git.Repo -> (FilePath -> [CommandParam] -> IO a) -> FilePath -> [CommandParam] -> Annex a
 onBupRemote r a command params = do
-	sshparams <- sshToRepo r [Param $
+	sshparams <- Ssh.toRepo r [Param $
 			"cd " ++ dir ++ " && " ++ unwords (command : toCommand params)]
 	liftIO $ a "ssh" sshparams
   where
diff --git a/Remote/Git.hs b/Remote/Git.hs
index 2802db9ae..2761995b2 100644
--- a/Remote/Git.hs
+++ b/Remote/Git.hs
@@ -14,8 +14,6 @@ module Remote.Git (
 ) where
 
 import Common.Annex
-import Utility.Rsync
-import Remote.Helper.Ssh
 import Annex.Ssh
 import Types.Remote
 import Types.GitConfig
@@ -45,6 +43,8 @@ import Utility.Metered
 import Utility.CopyFile
 #endif
 import Remote.Helper.Git
+import Remote.Helper.Messages
+import qualified Remote.Helper.Ssh as Ssh
 import qualified Remote.GCrypt
 
 import Control.Concurrent
@@ -143,7 +143,7 @@ tryGitConfigRead :: Git.Repo -> Annex Git.Repo
 tryGitConfigRead r 
 	| haveconfig r = return r -- already read
 	| Git.repoIsSsh r = store $ do
-		v <- onRemote r (pipedconfig, Left undefined) "configlist" [] []
+		v <- Ssh.onRemote r (pipedconfig, Left undefined) "configlist" [] []
 		case v of
 			Right r'
 				| haveconfig r' -> return r'
@@ -241,28 +241,19 @@ inAnnex r key
 	| otherwise = checklocal
   where
 	checkhttp headers = do
-		showchecking
+		showChecking r
 		liftIO $ ifM (anyM (\u -> Url.check u headers (keySize key)) (keyUrls r key))
 			( return $ Right True
 			, return $ Left "not found"
 			)
-	checkremote = do
-		showchecking
-		onRemote r (check, unknown) "inannex" [Param (key2file key)] []
-	  where
-		check c p = dispatch <$> safeSystem c p
-		dispatch ExitSuccess = Right True
-		dispatch (ExitFailure 1) = Right False
-		dispatch _ = unknown
-	checklocal = guardUsable r unknown $ dispatch <$> check
+	checkremote = Ssh.inAnnex r key
+	checklocal = guardUsable r (cantCheck r) $ dispatch <$> check
 	  where
 		check = liftIO $ catchMsgIO $ onLocal r $
 			Annex.Content.inAnnexSafe key
 		dispatch (Left e) = Left e
 		dispatch (Right (Just b)) = Right b
-		dispatch (Right Nothing) = unknown
-	unknown = Left $ "unable to check " ++ Git.repoDescribe r
-	showchecking = showAction $ "checking " ++ Git.repoDescribe r
+		dispatch (Right Nothing) = cantCheck r
 
 keyUrls :: Git.Repo -> Key -> [String]
 keyUrls r key = map tourl locs
@@ -285,12 +276,8 @@ dropKey r key
 				logStatus key InfoMissing
 				Annex.Content.saveState True
 			return True
-	| Git.repoIsHttp (repo r) = error "dropping from http repo not supported"
-	| otherwise = commitOnCleanup r $ onRemote (repo r) (boolSystem, False) "dropkey"
-		[ Params "--quiet --force"
-		, Param $ key2file key
-		]
-		[]
+	| Git.repoIsHttp (repo r) = error "dropping from http remote not supported"
+	| otherwise = commitOnCleanup r $ Ssh.dropKey (repo r) key
 
 {- Tries to copy a key's content from a remote's annex to a file. -}
 copyFromRemote :: Remote -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex Bool
@@ -298,7 +285,7 @@ copyFromRemote r key file dest _p = copyFromRemote' r key file dest
 copyFromRemote' :: Remote -> Key -> AssociatedFile -> FilePath -> Annex Bool
 copyFromRemote' r key file dest
 	| not $ Git.repoIsUrl (repo r) = guardUsable (repo r) False $ do
-		let params = rsyncParams r
+		let params = Ssh.rsyncParams r
 		u <- getUUID
 		-- run copy from perspective of remote
 		liftIO $ onLocal (repo r) $ do
@@ -311,10 +298,10 @@ copyFromRemote' r key file dest
 						(rsyncOrCopyFile params object dest)
 						<&&> checksuccess
 	| Git.repoIsSsh (repo r) = feedprogressback $ \feeder -> 
-		rsyncHelper (Just feeder) 
-			=<< rsyncParamsRemote r Download key dest file
+		Ssh.rsyncHelper (Just feeder) 
+			=<< Ssh.rsyncParamsRemote r Download key dest file
 	| Git.repoIsHttp (repo r) = Annex.Content.downloadUrl (keyUrls (repo r) key) dest
-	| otherwise = error "copying from non-ssh, non-http repo not supported"
+	| otherwise = error "copying from non-ssh, non-http remote not supported"
   where
 	{- Feed local rsync's progress info back to the remote,
 	 - by forking a feeder thread that runs
@@ -339,7 +326,7 @@ copyFromRemote' r key file dest
 		u <- getUUID
 		let fields = (Fields.remoteUUID, fromUUID u)
 			: maybe [] (\f -> [(Fields.associatedFile, f)]) file
-		Just (cmd, params) <- git_annex_shell (repo r) "transferinfo" 
+		Just (cmd, params) <- Ssh.git_annex_shell (repo r) "transferinfo" 
 			[Param $ key2file key] fields
 		v <- liftIO $ (newEmptySV :: IO (MSampleVar Integer))
 		tid <- liftIO $ forkIO $ void $ tryIO $ do
@@ -385,7 +372,8 @@ copyToRemote r key file p
 			copylocal =<< Annex.Content.prepSendAnnex key
 	| Git.repoIsSsh (repo r) = commitOnCleanup r $
 		Annex.Content.sendAnnex key noop $ \object ->
-			rsyncHelper (Just p) =<< rsyncParamsRemote r Upload key object file
+			Ssh.rsyncHelper (Just p)
+				=<< Ssh.rsyncParamsRemote r Upload key object file
 	| otherwise = error "copying to non-ssh repo not supported"
   where
 	copylocal Nothing = return False
@@ -394,7 +382,7 @@ copyToRemote r key file p
 		-- the remote's Annex, but it needs access to the current
 		-- Annex monad's state.
 		checksuccessio <- Annex.withCurrentState checksuccess
-		let params = rsyncParams r
+		let params = Ssh.rsyncParams r
 		u <- getUUID
 		-- run copy from perspective of remote
 		liftIO $ onLocal (repo r) $ ifM (Annex.Content.inAnnex key)
@@ -446,56 +434,9 @@ rsyncOrCopyFile rsyncparams src dest p =
 					watchfilesize sz
 			_ -> watchfilesize oldsz
 #endif
-	dorsync = rsyncHelper (Just p) $
+	dorsync = Ssh.rsyncHelper (Just p) $
 		rsyncparams ++ [File src, File dest]
 
-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)
-
 commitOnCleanup :: Remote -> Annex a -> Annex a
 commitOnCleanup r a = go `after` a
   where
@@ -506,7 +447,7 @@ commitOnCleanup r a = go `after` a
 				Annex.Branch.commit "update"
 		| otherwise = void $ do
 			Just (shellcmd, shellparams) <-
-				git_annex_shell (repo r) "commit" [] []
+				Ssh.git_annex_shell (repo r) "commit" [] []
 			
 			-- Throw away stderr, since the remote may not
 			-- have a new enough git-annex shell to
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)
+