From 0f1ea37a68535b95c56e1e142ecc8db1ac6b43dc Mon Sep 17 00:00:00 2001
From: Joey Hess <joey@kitenet.net>
Date: Sat, 12 Apr 2014 16:32:59 -0400
Subject: remotedaemon: When network connection is lost, close all cached ssh
 connections.

This commit was sponsored by Cedric Staub.
---
 Annex/Ssh.hs | 55 +++++++++++++++++++++++++++++++++----------------------
 1 file changed, 33 insertions(+), 22 deletions(-)

(limited to 'Annex/Ssh.hs')

diff --git a/Annex/Ssh.hs b/Annex/Ssh.hs
index fab25c462..06e3ac449 100644
--- a/Annex/Ssh.hs
+++ b/Annex/Ssh.hs
@@ -11,6 +11,7 @@ module Annex.Ssh (
 	sshCachingOptions,
 	sshCacheDir,
 	sshReadPort,
+	forceSshCleanup,
 	sshCachingEnv,
 	sshCachingTo,
 	inRepoWithSshCachingTo,
@@ -124,21 +125,27 @@ prepSocket socketfile = do
 	liftIO $ createDirectoryIfMissing True $ parentDir socketfile
 	lockFile $ socket2lock socketfile
 
-{- Stop any unused ssh processes. -}
+enumSocketFiles :: Annex [FilePath]
+enumSocketFiles = go =<< sshCacheDir
+  where
+	go Nothing = return []
+	go (Just dir) = liftIO $ filter (not . isLock)
+		<$> catchDefaultIO [] (dirContents dir)
+
+{- Stop any unused ssh connection caching processes. -}
 sshCleanup :: Annex ()
-sshCleanup = go =<< sshCacheDir
+sshCleanup = mapM_ cleanup =<< enumSocketFiles
   where
-	go Nothing = noop
-	go (Just dir) = do
-		sockets <- liftIO $ filter (not . isLock)
-			<$> catchDefaultIO [] (dirContents dir)
-		forM_ sockets cleanup
 	cleanup socketfile = do
 #ifndef mingw32_HOST_OS
 		-- Drop any shared lock we have, and take an
 		-- exclusive lock, without blocking. If the lock
 		-- succeeds, nothing is using this ssh, and it can
 		-- be stopped.
+		--
+		-- After ssh is stopped cannot remove the lock file;
+		-- other processes may be waiting on our exclusive
+		-- lock to use it.
 		let lockfile = socket2lock socketfile
 		unlockFile lockfile
 		mode <- annexFileMode
@@ -148,24 +155,28 @@ sshCleanup = go =<< sshCacheDir
 			setLock fd (WriteLock, AbsoluteSeek, 0, 0)
 		case v of
 			Left _ -> noop
-			Right _ -> stopssh socketfile
+			Right _ -> forceStopSsh socketfile
 		liftIO $ closeFd fd
 #else
-		stopssh socketfile
+		forceStopSsh socketfile
 #endif
-	stopssh socketfile = do
-		let (dir, base) = splitFileName socketfile
-		let params = sshConnectionCachingParams base
-		-- "ssh -O stop" is noisy on stderr even with -q
-		void $ liftIO $ catchMaybeIO $
-			withQuietOutput createProcessSuccess $
-				(proc "ssh" $ toCommand $
-					[ Params "-O stop"
-					] ++ params ++ [Param "localhost"])
-					{ cwd = Just dir }
-		liftIO $ nukeFile socketfile
-		-- Cannot remove the lock file; other processes may
-		-- be waiting on our exclusive lock to use it.
+
+{- Stop all ssh connection caching processes, even when they're in use. -}
+forceSshCleanup :: Annex ()
+forceSshCleanup = mapM_ forceStopSsh =<< enumSocketFiles
+
+forceStopSsh :: FilePath -> Annex ()
+forceStopSsh socketfile = do
+	let (dir, base) = splitFileName socketfile
+	let params = sshConnectionCachingParams base
+	-- "ssh -O stop" is noisy on stderr even with -q
+	void $ liftIO $ catchMaybeIO $
+		withQuietOutput createProcessSuccess $
+			(proc "ssh" $ toCommand $
+				[ Params "-O stop"
+				] ++ params ++ [Param "localhost"])
+				{ cwd = Just dir }
+	liftIO $ nukeFile socketfile
 
 {- This needs to be as short as possible, due to limitations on the length
  - of the path to a socket file. At the same time, it needs to be unique
-- 
cgit v1.2.3