sync, assistant, remotedaemon: Use ssh connection caching for git pushes and pulls.

For sync, saves 1 ssh connection per remote. For remotedaemon, the same
ssh connection that is already open to run git-annex-shell notifychanges
is reused to pull from the remote.

Only potential problem is that this also enables connection caching
when the assistant syncs with a ssh remote. Including the sync it does
when a network connection has just come up. In that case, cached ssh
connections are likely to be stale, and so using them would hang.
Until I'm sure such problems have been dealt with, this commit needs to
stay on the remotecontrol branch, and not be merged to master.

This commit was sponsored by Alexandre Dupas.

2 files changed, 92 insertions, 27 deletions

diff --git a/Annex/Index.hs b/Annex/Index.hs
index a1b2442fc..af0cab45e 100644
--- a/Annex/Index.hs
+++ b/Annex/Index.hs
@@ -9,6 +9,7 @@
 
 module Annex.Index (
 	withIndexFile,
+	addGitEnv,
 ) where
 
 import qualified Control.Exception as E
@@ -23,24 +24,30 @@ import Annex.Exception
 withIndexFile :: FilePath -> Annex a -> Annex a
 withIndexFile f a = do
 	g <- gitRepo
-#ifdef __ANDROID__
-	{- This should not be necessary on Android, but there is some
-	 - weird getEnvironment breakage. See
-	 - https://github.com/neurocyte/ghc-android/issues/7
-	 - Use getEnv to get some key environment variables that
-	 - git expects to have. -}
-	let keyenv = words "USER PATH GIT_EXEC_PATH HOSTNAME HOME"
-	let getEnvPair k = maybe Nothing (\v -> Just (k, v)) <$> getEnv k
-	e <- liftIO $ catMaybes <$> forM keyenv getEnvPair
-	let e' = ("GIT_INDEX_FILE", f):e
-#else
-	e <- liftIO getEnvironment
-	let e' = addEntry "GIT_INDEX_FILE" f e
-#endif
-	let g' = g { gitEnv = Just e' }
+	g' <- liftIO $ addGitEnv g "GIT_INDEX_FILE" f
 
 	r <- tryAnnex $ do
 		Annex.changeState $ \s -> s { Annex.repo = g' }
 		a
 	Annex.changeState $ \s -> s { Annex.repo = (Annex.repo s) { gitEnv = gitEnv g} }
 	either E.throw return r
+
+addGitEnv :: Repo -> String -> String -> IO Repo
+addGitEnv g var val = do
+	e <- maybe copyenv return (gitEnv g)
+	let e' = addEntry var val e
+	return $ g { gitEnv = Just e' }
+  where
+	copyenv = do
+#ifdef __ANDROID__
+		{- This should not be necessary on Android, but there is some
+		 - weird getEnvironment breakage. See
+		 - https://github.com/neurocyte/ghc-android/issues/7
+		 - Use getEnv to get some key environment variables that
+		 - git expects to have. -}
+		let keyenv = words "USER PATH GIT_EXEC_PATH HOSTNAME HOME"
+		let getEnvPair k = maybe Nothing (\v -> Just (k, v)) <$> getEnv k
+		liftIO $ catMaybes <$> forM keyenv getEnvPair
+#else
+		liftIO getEnvironment
+#endif
diff --git a/Annex/Ssh.hs b/Annex/Ssh.hs
index bd10a40d4..fab25c462 100644
--- a/Annex/Ssh.hs
+++ b/Annex/Ssh.hs
@@ -1,6 +1,6 @@
 {- git-annex ssh interface, with connection caching
  -
- - Copyright 2012,2013 Joey Hess <joey@kitenet.net>
+ - Copyright 2012-2014 Joey Hess <joey@kitenet.net>
  -
  - Licensed under the GNU GPL version 3 or higher.
  -}
@@ -11,19 +11,28 @@ module Annex.Ssh (
 	sshCachingOptions,
 	sshCacheDir,
 	sshReadPort,
+	sshCachingEnv,
+	sshCachingTo,
+	inRepoWithSshCachingTo,
+	runSshCaching,
 ) where
 
 import qualified Data.Map as M
 import Data.Hash.MD5
 import System.Process (cwd)
+import System.Exit
 
 import Common.Annex
 import Annex.LockPool
 import qualified Build.SysConfig as SysConfig
 import qualified Annex
+import qualified Git
+import qualified Git.Url
 import Config
+import Config.Files
 import Utility.Env
 import Types.CleanupActions
+import Annex.Index (addGitEnv)
 #ifndef mingw32_HOST_OS
 import Annex.Perms
 #endif
@@ -31,22 +40,13 @@ import Annex.Perms
 {- Generates parameters to ssh to a given host (or user@host) on a given
  - port, with connection caching. -}
 sshCachingOptions :: (String, Maybe Integer) -> [CommandParam] -> Annex [CommandParam]
-sshCachingOptions (host, port) opts = do
-	Annex.addCleanup SshCachingCleanup sshCleanup
-	go =<< sshInfo (host, port)
+sshCachingOptions (host, port) opts = go =<< sshInfo (host, port)
   where
 	go (Nothing, params) = ret params
 	go (Just socketfile, params) = do
-		cleanstale
-		liftIO $ createDirectoryIfMissing True $ parentDir socketfile
-		lockFile $ socket2lock socketfile
+		prepSocket socketfile
 		ret params
 	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.
-	cleanstale = whenM (not . any isLock . M.keys <$> getPool)
-		sshCleanup
 
 {- Returns a filename to use for a ssh connection caching socket, and
  - parameters to enable ssh connection caching. -}
@@ -109,6 +109,21 @@ portParams :: Maybe Integer -> [CommandParam]
 portParams Nothing = []
 portParams (Just port) = [Param "-p", Param $ show port]
 
+{- Prepare to use a socket file. Locks a lock file to prevent
+ - other git-annex processes from stopping the ssh on this socket. -}
+prepSocket :: FilePath -> Annex ()
+prepSocket socketfile = do
+	-- 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.
+	whenM (not . any isLock . M.keys <$> getPool)
+		sshCleanup
+	-- Cleanup at end of this run.
+	Annex.addCleanup SshCachingCleanup sshCleanup
+
+	liftIO $ createDirectoryIfMissing True $ parentDir socketfile
+	lockFile $ socket2lock socketfile
+
 {- Stop any unused ssh processes. -}
 sshCleanup :: Annex ()
 sshCleanup = go =<< sshCacheDir
@@ -199,3 +214,46 @@ sshReadPort params = (port, reverse args)
 	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
+
+{- When this env var is set, git-annex runs ssh with parameters
+ - to use the socket file that the env var contains.
+ -
+ - This is a workaround for GiT_SSH not being able to contain
+ - additional parameters to pass to ssh. -}
+sshCachingEnv :: String
+sshCachingEnv = "GIT_ANNEX_SSHCACHING"
+
+{- Enables ssh caching for git push/pull to a particular
+ - remote git repo. (Can safely be used on non-ssh remotes.)
+ -
+ - Like inRepo, the action is run with the local git repo.
+ - But here it's a modified version, with gitEnv to set GIT_SSH=git-annex,
+ - and sshCachingEnv set so that git-annex will know what socket
+ - file to use. -}
+inRepoWithSshCachingTo :: Git.Repo -> (Git.Repo -> IO a) -> Annex a
+inRepoWithSshCachingTo remote a =
+	liftIO . a =<< sshCachingTo remote =<< gitRepo
+
+{- To make any git commands be run with ssh caching enabled, 
+ - alters the local Git.Repo's gitEnv to set GIT_SSH=git-annex,
+ - and set sshCachingEnv so that git-annex will know what socket
+ - file to use. -}
+sshCachingTo :: Git.Repo -> Git.Repo -> Annex Git.Repo
+sshCachingTo remote g = case Git.Url.hostuser remote of
+	Nothing -> return g
+	Just host -> do
+		(msockfile, _) <- sshInfo (host, Git.Url.port remote)
+		case msockfile of
+			Nothing -> return g
+			Just sockfile -> do
+				command <- liftIO readProgramFile
+				prepSocket sockfile
+				liftIO $ do
+					g' <- addGitEnv g sshCachingEnv sockfile
+					addGitEnv g' "GIT_SSH" command
+
+runSshCaching :: [String] -> String -> IO ()
+runSshCaching args sockfile = do
+	let args' = toCommand (sshConnectionCachingParams sockfile) ++ args
+	let p = proc "ssh" args'
+	exitWith =<< waitForProcess . processHandle =<< createProcess p